;;;
;;;   Compiler/Parser Initialization Programs
;;;

(print "******************************************************")
(print "**  The Generalized LR Parser/Compiler/Interpreter  **")
(print "**             with Generation KIT                  **")
(print "**               RT version 8-4                     **")
(print "**        Center for Machine Translation            **")
(print "**          Carnegie Mellon University              **")
(print "**    (c) 1986, 1987, 1988 All rights reserved      **")
(print "******************************************************")
(terpri)
(print "This version includes INTERPRETER that does not require
	grammar compilation.  Type (HELP) for more description.")
(terpri)
(print "------------------------------------------------------")
(print "WARNING: Any use of this software outside CMU without ")
(print "         proper approval  from the Center for Machine ")
(print "         Translation or  Masaru Tomita is prohibited. ")
(print "------------------------------------------------------")
(terpri)
(setq *features* (adjoin 'IBM-RT *features*))
(defvar *unification-mode* 'pseudo)	;;  'PSEUDO or 'FULL
(defvar bin-ext "fasl")

(defvar *compilers-loaded* t)
(defvar *parser-loaded* t)
(defun setup-parser () t)
(defun setup-compilers () t)

(defun load! (file)
  (princ "  Loading File - ")(princ file)(terpri)
  (load file))


;;; ==================================================================
;;;
;;;             	UTILITY FUNCTIONS
;;; 			-----------------
;;; 
;;; 			  Masaru Tomita
;;; 		  Center for Machine Translation
;;;		    Carnegie-Mellon University
;;; 
;;; ==================================================================
	
;;;   util.lisp consists of the following functions:
;;;
;;;     MAP-DOLIST, APPEND-DOLIST, OR-DOLIST, AND-DOLIST
;;;     COMPILE-FILE!, READ-FILE-LIST, WRITE-FILE-LIST, FILE-NEWER-THAN
;;; 	LOAD-NEWER-FILE, APPEND-STR, APPEND-FILES

;;; __________________________________________________________________
;;; 
;;;   DOLIST macros
;;; __________________________________________________________________
;;; 

;;; 
;;;   MAP-DOLIST is like DOLIST, except it returns a list of all results.
;;; 
(defmacro map-dolist (varlist body)
 (let ((map-result (gensym)))
 `(let ((,map-result nil))
    (dolist ,varlist (push ,body ,map-result))
     (nreverse ,map-result))))

;;; 
;;;   APPEND-DOLIST is like DOLIST, except it returns an appended list of
;;;       all results.
;;; 
(defmacro append-dolist (varlist body)
 (let ((append-result (gensym)))
  `(let ((,append-result nil))
    (dolist ,varlist (setq ,append-result (append ,body ,append-result)))
    ,append-result)))

;;; 
;;;    OR-DOLIST is like DOLIST, except that as soon as one of its
;;;        element returns a non-nil value, quit DOLIST and return
;;; 	   the value.  If all return nil, then return nil.
;;; 
(defmacro or-dolist (varlist body)
 (let ((result (gensym)))
  `(let ((,result nil))
    (dolist ,varlist
	 (setq ,result ,body)
	 (if ,result (return ,result))))))

;;; 
;;;    AND-DOLIST is like DOLIST, except that as soon as one of its
;;;        element returns nil value, quit DOLIST and return nil.
;;; 	   If all return non-nil values, then return the last value.
;;; 
(defmacro and-dolist (varlist body)
 (let ((result (gensym)))
  `(let ((,result nil))
    (dolist ,varlist
	 (setq ,result ,body)
	 (if (null ,result) (return nil)))
    ,result)))

;;; ___________________________________________________________________
;;; 
;;;   File I/O Functions
;;; ___________________________________________________________________
;;; 

;;; 
;;; COMPILE-FILE compiles files and then load it.
;;; 
(defun compile-file! (&rest file-names)
  (dolist (file-name file-names)
    (compile-file file-name)
    (load file-name)))

;;; 
;;; READ-FILE-LIST takes a file name and returns contents of the file
;;; as a list.
;;; 
(defun read-file-list (file)
 (let ((obj-list nil))
  (format t " - Reading ~A~%" file)
  (with-open-file (ifile file :direction :input)
    (do ((obj (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq obj '%eof%))
      (push obj obj-list)))
  (setq obj-list (nreverse obj-list))
  (format t " - ~A read~%" file)
  obj-list))

;;; 
;;; WRITE-FILE-LIST takes a list of objects and a file name as its
;;; arguments and writes each element of the list to the file.
;;; 
(defun write-file-list (obj-list file &key (if-exists :new-version))
  (let ((save-pretty-flag *print-pretty*))
   (setq *print-pretty* nil)
   (format t " - Writing File ~A~%" file)
   (with-open-file (ofile file :direction :output :if-exists if-exists)
     (princ ";;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;" ofile)
     (terpri ofile)
     (dolist (obj obj-list)
	(prin1 obj ofile)(terpri ofile)))
   (format t " - File ~A written~%" file)
   (setq *print-pretty* save-pretty-flag)))

;;;  If file1 is newer (later) than file2, return t, otherwise nil.
;;;  If both don't exist, return nil.
;;;  If file2 doesn't exist, return t.
;;;  If file1 doesn't exist, return nil.
;;;
(defun file-newer-than (file1 file2)
  (let ((file1-date (and (probe-file file1)(file-write-date file1)))
	(file2-date (and (probe-file file2)(file-write-date file2))))
    (cond ((null (or file1-date file2-date)) nil)
	  ((null file2-date) t)
	  ((null file1-date) nil)
	  (t (> file1-date file2-date)))))

;;; 
;;;  LOAD-NEWER-FILE loads whichever of file1 and file2 is newer.
;;; 
(defun load-newer-file (file1 file2)
  (cond ((file-newer-than file1 file2)
	 (format t " - Loading ~A~%" file1)
	 (load file1))
	(t
	 (format t " - Loading ~A~%" file2)
   	 (load file2))))
;;; 
;;;  (append-str "masaru" "tomita") ==> "masarutomita"
;;;
(defun append-str (str1 str2 &optional (str3 "")(str4 ""))
  (concatenate 'string str1 str2 str3 str4))

;;;    (explode-string "tomita") ==> (t o m i t a)
;;;
(defun explode-string (instring)
  (explode-input-string (remove #\  instring)))

(defun explode-input-string (string)
  (map 'list #'(lambda (char) (intern (string (char-upcase char)))) string))

;;;    (root-symbol "get rid of") ==> GET-RID-OF
;;;
(defun root-symbol (instring)
  (intern (string-upcase (substitute #\- #\space instring))))

;;; 
;;;  Append files a b c into d.
;;;  (append-files '("a" "b" "c") "d")
;;; 
(defun append-files (file-name-list dest-file)
  (dolist (file-name  file-name-list)
	(write-file-list (read-file-list file-name)
			 dest-file :if-exists :append)))
;;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;

;;; 
;;;  Global variables
;;; 
(defvar *unification-mode* 'PSEUDO)  ; 'PSEUDO or 'FULL

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	COMPSUB -  Compile a sub-grammar.  Called by LOADGRA.
;;;       gra-file - stem of the grammar file name to be compiled.
;;;	  :subtype - MAIN - main grammar
;;;		   - LEX  - sub lexical grammar (there is no non-terminal
;;;			    except the start symbol).
;;;		   - GRA  - sub gramamr which is not lexical
;;;			    (not used in v7.5).
;;;
(defun compsub (gra-file &key (subtype 'main))
  (prog (mgra gra acfg  ;; grammars in different forms
 	 fun-list	;; list of function definitions (defun)
	 table	)	;; list of grammar-rules action-table and goto-table

       ;; If .gra file has not been modified after the last compilation,
       ;; simply load .tab file and return the table.
       ;;
    (when (file-newer-than (append-str gra-file ".tab")
			   (append-str gra-file ".gra"))
	(format t "***** No need to compile ~A.gra again~%" gra-file)
	(setq table (read-table (append-str gra-file ".tab")))
 	(return table))

       ;; Otherwise

       ;; Load .gra file into the variable mgra.
       ;; READ-FILE-LIST defined by kagamida.
       ;;
    (format t "~%~%************************************************~%")
    (format t "***** Start compiling ~A.gra~%" gra-file)
    (setq mgra (read-file-list (append-str gra-file ".gra")))

       ;; Expand macros in the grammar file.
       ;; GRA-PREPROCESS formerly called mgra-to-gra.
       ;;
    (setq gra (gra-preprocess mgra))

       ;; Compile LFG equations into LISP functions.
       ;; LFG-COMPILER (formally called AC7) defined in "lfg-compiler.lisp".
       ;; Returns ((rule1 rule2 ...)(defun1 defun2 ...))
       ;; where rulen is	
       ;; (lhs-symbol list-of-rhs-symbols fun-name)
       ;; and defunn is normal defun definition.
       ;;
    (case *unification-mode*
       (PSEUDO (setq acfg (lfg-compiler gra :gra-file gra-file)))
       (FULL   (setq acfg (lfg-compiler-full gra :gra-file gra-file))))
    (setq fun-list (second acfg))	;; function definitions
    (setq acfg (first acfg))		;; cfg rules with a function name

       ;; Make LR Table from ACFG
       ;; LR-TABLE-COMPILER (formerly called tg25) and LR-TABLE-COMPILER-LEX
       ;; defined by Kagamida in "lr-table-compiler.lisp".
       ;;
       ;; If :subtype is 'lex, call lr-table-compiler-lex.
       ;;  That is, if the grammar is a lexical grammar, a much simpler method
       ;; can be used.
       ;;
    (if (eq subtype 'lex)
	(setq table (lr-table-compiler-lex acfg))
        (setq table (lr-table-compiler acfg)))

       ;; Write Table to file.  WRITE-TABLE defined by Kagamida
       ;;
    (write-table table (append-str gra-file ".tab"))

       ;; Write function definitions to file. 
       ;; WRITE-FILE-LIST defined by Kagamida.
       ;;
    (write-file-list fun-list (append-str gra-file ".fun"))

       ;; Returns table as compsub's value
       ;;
    (return table)
 ))

    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	COMPGRA - compile .gra file (possibly with subgrammars)
;;;		  into .mtab file.  (6/1/87 mt)
;;;	   
;;;	main-gra-file - stem of the name of file you want to compile.
;;;	:result-to-file - if nil, it doesn't write final table to file,
;;;	  saving time.  Set it nil, if you know your grammar has bugs,
;;;	  and you want to test it quickly.
;;;	:parser-ready - if nil, it doesn't set up the parser, saving time.
;;;	  Set it nil, if you don't want to test your grammar immediately.
;;;
(defun compgra (main-gra-file &key (result-to-file t) (parser-ready t))
 
    ;; Local variables
    ;;
 (prog (sub-files sub-lex-files sub-gra-files		;; list of filenames
	sub-lex-tables sub-gra-tables			;; list of tables
	main-gra-table final-table)			;; table

     ;; Load all programs (defined in cmu-parser-rt.init)
  (setup-compilers)	

     ;; Look for (@lex "...")'s and/or (@gra "...")'s in main-gra-file.
     ;; FIND-SUB-FILES returns a list of sub-lex-files and sub-gra-files.
     ;;
  (setq sub-files (find-sub-files (append-str main-gra-file ".gra")))
  (setq	sub-lex-files (first sub-files))  ;; list of sub-lex file names (stem)
  (setq sub-gra-files (second sub-files)) ;; list of sub-gra file names (stem)

     ;; Compile the main grammar.  COMPSUB does the job, and returns
     ;; a grammar table for the main grammar.
     ;;
  (setq main-gra-table (compsub main-gra-file :subtype 'main))

     ;; Compile all sub-lex grammars.  Set the list of results into
     ;; sub-lex-tables.  MAP-DOLIST defined in "unify4.lisp"
     ;;
  (setq sub-lex-tables
	 (map-dolist (sub-lex-file sub-lex-files)
	   (compsub sub-lex-file :subtype 'lex)))

     ;; Compile all sub grammars.  Set the list of results into
     ;; sub-gra-tables.
     ;;
  (setq sub-gra-tables
	 (map-dolist (sub-gra-file sub-gra-files)
	   (compsub sub-gra-file :subtype 'gra)))

     ;; Merge all sub tables.  TABLE-MERGE defined by Kagamida.
     ;;
  (if (or sub-lex-tables sub-gra-tables)
      (let ()
       (setq final-table
	 (table-merge main-gra-table
	      (append sub-lex-tables sub-gra-tables)))) ;; All subfiles
      (setq final-table main-gra-table))

     ;; Writing the final-table to file.  WRITE-TABLE defined by Kagamida.
     ;;
  (when result-to-file
	 ;; If the main grammar doesn't have any sub files, ".tab"
	 ;; file is the final file, and no need to write again.
      (if (or sub-lex-files sub-gra-files)
 	  (write-table final-table (append-str main-gra-file ".mtab"))))

     ;; Creating .funload file.  MAKE-FUNLOAD-FILE defined by mt.
     ;;
  (make-funload-file main-gra-file (append sub-lex-files sub-gra-files))

     ;; Set up the run time parser.  The run time parser defined by Musha.
     ;; *grammar-table*, *action-table* and *goto-table* are grobal variables
     ;; defined in "offline-parser.lisp".
     ;;
  (when parser-ready
    (format t "***** Setting up the runtime parser~%")
    (setup-parser)     ;; Load parser and fkit (defined in cmu-parser-rt.init)
;    (setq *gg* (first final-table))
;    (setq *a-tab* (second final-table))
;    (setq *g-tab* (third final-table))
;    (make-tables)		;; Defined by Musha in offline-parser
;    (if (or sub-lex-files sub-gra-files)
;	   ;; If there are sub files, load ".funload" file that actually
;	   ;; loads all ".fun" files necessary.  	
;        (load! (append-str main-gra-file ".funload"))
;	   ;; If none, load simply ".fun" file of the main grammar.
;	(load! (append-str main-gra-file ".fun")))
    (loadgra main-gra-file))
;    (format t "Parser Ready"))
 ))

;;; 
;;; CONSTIT-LIST - used in COMPILE-AUGMENTATION.
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;; _________________________________________________________________	
;;;
;;;	   COMPILE-AUGMENTATION 
;;;	    rhs-len : the length of right hand side
;;;	    statements : list of LFG equations
;;;        Returns (lambda (x1 x2 ..) ..lisp-code..)
;;;
(defun compile-augmentation (rhs-len statements)
  (declare (fixnum rhs-len))
  (let* ((reg-list            (subseq CONSTIT-LIST 1 (1+ rhs-len)))
	 (compiled-statements (compile-statements statements))
	 (used-regs           (collect-registers compiled-statements))
	 (not-used-regs       (set-difference reg-list used-regs))
	 (cons-list           (make-cons-list used-regs)))
    (append
      `(lambda ,reg-list)
      (when not-used-regs ; if there is registers for no use
	`((declare (ignore ,@not-used-regs))))
      `((let ((x (list (list ,@cons-list))))
	  (and ,compiled-statements
	       (or (getvalue* x '(x0)) t)))))))

;;;;;     collect-registers()
(defvar *register-bag*)
(defun collect-registers-sub (form)
  (if (atom form)
      (when (and (registerp form)
		 (not (eq form 'x0)))
	(pushnew form *register-bag*))
      (dolist (f form)
	(collect-registers-sub f))))

(defun collect-registers (form)
  (setq *register-bag* nil)
  (collect-registers-sub form)
  *register-bag*)


(defun make-cons-list (reg-list)
  (mapcar #'(lambda (reg) `(list (quote ,reg) ,reg)) reg-list))

(defun registerp (x)
   (member x CONSTIT-LIST))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;   	LFG-COMPILER - compile lfg grammar into ACFG and FUN-LIST 
;;;	 an element of ACFG :     (<S> (<NP> <V>) IBMF-34)
;;;	 an element of FUN-LIST : (defun IBMF-34 (..) ...)
;;;	  6/2/87 mt
;;;
(defun lfg-compiler (gra &key gra-file)		;; used in function names

 (let ((fun-list nil)				;;function definitions
       (acfg nil)				;; acfg rule list
       (count 0))				;; counter
  (format t "*** LFG Compiler started~%")
  (gensym 0)
  (dolist (rule gra)
   (let* ((lhs (first rule))			;; left hand side symbol
	  (rhs (second rule))			;; right hand side symbols
	  (aug (third rule))			;; augmentation
	  (lisp-func				;; generated lisp function
	      (compile-augmentation (length rhs) aug))
 	  (func-name
	       (intern (string-upcase
	 		 (append-str gra-file
				    (symbol-name (gensym "F-")))))))
    (incf count)
    (when (zerop (mod count 20))
	  (format t "LFG [~3D]~%" count))

	;; Push final function definition to FUN-LIST.
	;;
    (push `(defun ,func-name ,@(rest lisp-func))
	    fun-list )
	
	;; Push rule with function name into ACFG.
	;;
    (push (list lhs rhs func-name) acfg)

 ;; (format t "~A~%" (symbol-name func-name))
   ))

	;; Return a list of ACFG and FUN-LIST.
  (setq acfg (nreverse acfg))
  (setq fun-list (nreverse fun-list))
  (format t "*** LFG Compiler done~%")
  (list acfg fun-list))
)



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	LOADGRA - load table and function definitions
;;;	 for the runtime parser.
;;;
(defun loadgra (main-gra-file)
  (setup-parser)
  (cond    ;; If .fasl file available, load it.
	   ;; It includes function definitions.
	((file-newer-than (append-str main-gra-file ".fasl")
			  (append-str main-gra-file ".mtab"))
	 (load! (append-str main-gra-file ".fasl")))

	   ;; If .mtab file available, load it and .loadgra file.
	   ;; The .loadgra file actually loads all .fun files needed.
	((file-newer-than (append-str main-gra-file ".mtab")
			  (append-str main-gra-file ".tab"))
	 (load! (append-str main-gra-file ".mtab"))
	 (load! (append-str main-gra-file ".funload")))

	   ;; Otherwise, load .tab and .fun files.
	(t
 	 (load! (append-str main-gra-file ".tab"))
	 (load! (append-str main-gra-file ".fun"))))
  (make-tables)		;; defined by Musha in offline-parser
  (format t "  Parser Ready for ~A~%" main-gra-file))

;;;	MAKE-GRA-FAST - append all table/fun files into one file
;;;	and compile-file the file, to spped up runtime and loading
;;;	time.
;;;
(defun make-gra-fast (gra-file)
  (unless *compilers-loaded* (setup-compilers))

  (let ((sub-files (find-sub-files (append-str gra-file ".gra"))))
   (setq sub-files (append (first sub-files)(second sub-files)))
   (if sub-files
	  (write-table
	     (read-table (append-str gra-file ".mtab"))
	     (append-str gra-file ".temp"))
	  (write-table
	     (read-table (append-str gra-file ".tab"))
	     (append-str gra-file ".temp")))
   (write-file-list
		(read-file-list (append-str gra-file ".fun"))
		(append-str gra-file ".temp")
		:if-exists :append)
   (dolist (sub-file sub-files)
	    (write-file-list
		(read-file-list (append-str sub-file ".fun"))
		(append-str gra-file ".temp")
		:if-exists :append))
   (compile-file (append-str gra-file ".temp"))
   (delete-file (append-str gra-file ".temp"))
))


;;;  READ-TABLE & WRITE-TABLE - Read and write parsing table
;;;  a parsing table looks like the following:
;;;
;;;     (setq *gg* '( (rule1) (rule2)....))
;;;	(setq *a-tab* '( (state0)(state1)....))
;;;	(setq *g-tab* '( (state0)(state1)....))
;;;
(defun read-table (file)
  (let* ((raw-table (read-file-list file))
					 ; take off "(setq *gg* '("
	 (gg (cadr (third (first raw-table))))   
					 ; take off "(setq *a-tab* '("
         (a-tab (cadr (third (second raw-table)))) 
					 ; take off "(setq *g-tab* '("
	 (g-tab (cadr (third (third raw-table)))))
   (list gg a-tab g-tab)))

	
(defun write-table (table file &key (if-exists :new-version))
   (format t " - Writing File ~A~%" file)
   (with-open-file (ofile file :direction :output :if-exists if-exists)
     (princ ";;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;" ofile)
     (terpri ofile)
     (format ofile "(setq *gg* '(~%")
     (dolist (obj (first table))
	  (princ obj ofile)(terpri ofile))
     (format ofile "))~%")
     (format ofile "(setq *a-tab* '(~%")
     (dolist (obj (second table))
	  (princ obj ofile)(terpri ofile))
     (format ofile "))~%")
     (format ofile "(setq *g-tab* '(~%")
     (dolist (obj (third table))
	  (princ obj ofile)(terpri ofile))
     (format ofile "))~%"))
   (format t " - File ~A written~%" file))


;;;  MAKE-LOADGRA-FILE("main", '("sub1" "sub2" ...))
;;;  Returns file with the following statements.
;;;   (load! "main.fun")	;; load! defined by mt, same as load
;;;   (load! "sub1.fun")	;; except it displays status.
;;;   (load! "sub2.fun")
;;;
(defun make-funload-file (main-gra-file sub-files)
  (let ((load-statements nil))
    (setq load-statements
	  (map-dolist (sub-file (cons main-gra-file sub-files))
	     `(load!
		 ,(concatenate 'string sub-file ".fun"))))
    (write-file-list load-statements (append-str main-gra-file ".funload"))))
;;;		  LastEditDate = Thu Dec  3 13:38:25 1987  - Steve Morrisson
;;;   History (in reverse order)
;;;   dec 3  Stephen E. Morrisson
;;;          1/ modified p to print semmantic parse-list (if *semantics* is t)

;;;   old History.
;*************
; 6/03/87   add wild card
; 
; 6/22/87   adding failure recovery.
;    moddifying functions are:
;       parse-list
;	get-action
;            	if lookahead is '$$ (*failure-lookahead*) then it will
;		return reduce union table entry
;       make-action-table
;		add make-reduce-union-table in which we store all the reduce
;		actions at the state
;       make-reduce-union-table
;        	newly added  (see above)
;;;   22-july-87 Stephen E. Morrisson (sem)
;;;            added *parser-return-value* to allow the parser to
;;;            return a value when needed.
; 7/29/87  change the following two functions in order to deal use eronious
;	   goto table entry.
;	get-goto-state    when no state is listed on the table, print error
;           message and return -1
;	get-action     if the current state is -1 (i.e. erronious goto table
;	    entry, then return nil
; 
; 9/18/87
;    parser-list (hence parse) returns nil if the parser fails and
;    *recover-from-failure is set nil
;
; 10/4/87
;    introduced another global variable *parse-value* to store the final value
;    obtained.  A change in function "disp-value"
; 
; to be done when the interface with compgra is changed.
;    distinguish rules with <--, <--> from <==, <==>.
;    When *ignore-space* is nil <-- or <--> can be applied anytime
;    but <==, and <==> can be applied only when the next character (lookahead)
;    is a space character or punctuation.
; 
; 10/20/87
;    add new global variable *warn-ambiguous-grammar* to display a warning
;    message when the values of nodes to be packed are the same.  For grammar
;    writers.
; 10/30/87
;    add *wild-card-stop-characters* so that wild character match stops seeing
;    that character.    
; declare.lisp   declaration of global variables and structures
;
; 11/11/88 mt
;    fix a bug by changing some of "category" to "node-category".
;    "category" was used for both structures "symbol-vertex" and "node",
;    and caused a problem on HP.
;

(defparameter *accept* 'A)	; 'a
(defparameter *shift* 'S)	; 's
(defparameter *wild-card-shift* 'SH*) 
(defparameter *reduce* 'R)	; 'r
(defparameter *fail-symbol* '<??>)  ; category to be used for recovery

(defvar *new-unify* t)		; after v7.5 it should be t
(defvar *parse-return-value* nil)   ; nil if parser should not return
                                    ; a list of values for a parse
(defvar *parse-value*)		; the value parser got at last
(defvar *recover-from-failure* nil) ; Set it t, if you wnt to output something
    				; even when the parser fails.

(defvar *parser-failed*)	; set to t when it failed
(defvar *number-of-failure-abmiguity* 1) ; how many paths to recover when
 					 ; failed
(defvar *active-killed* nil)	; To remember the actives killed during one
    				; sesson (dealing with a paticular
				; lookahead).
				; Used  in parse-list, recover-failure and
				; fill-actions.
(defvar *ignore-space* t)
(defconstant *space-character* '| |)
(defparameter *wild-card-character* '%)
(defparameter *wild-card-stop-characters* '(|"| |'|))
(defconstant *reduce-action-character* '*) ; when LR 0, all reduce actions are
				; stored under this symbol.
(defconstant *failure-lookahead* '$$)  ; used when parser fails. used as an
    				       ; dummy lookahead.

(defvar *no-ambiguity-packing* nil) ; If you do not want to pack ambiguities,
    				    ; set this t.
(defvar *max-ambiguity-display* 3) ; You do not want to display more than
     				; this number
(defvar *max-amb-sem-display* 3) ; Number of sem parses to display.
(defvar *semantics* nil) ;  This enables semantics use be other parts of
                         ; the system. - sem 12/3/87
(defvar *parse-number* 0)	; 08/12 sentence number

(defvar *warn-ambiguous-grammar* nil)


;; parsing tables
(defvar *grammar-table*)  	; array of grammar rules
(defvar *action-table*)		; array of action tables
(defvar *goto-table*)		; array of goto tables
(defvar *reduce-union-table*)   ; for recovery from failure

(defvar *GG*)			; rules, action table and goto table are bound
(defvar *A-TAB*)		; to these variables when the grammar is
(defvar *G-TAB*)		; loaded.

(defvar *start-symbol*)		; rhs of the first rule.
(defvar *text*)			; default input text
(defvar *out* t "where to output the result")

(defvar *state-array*)		; array for state vertex
(defvar *symbol-array*)		; array for symbol vertex
(defvar *node-array*)		; array for node

(defparameter *initial-vertex-size* 1000)
(defparameter *initial-node-size* 1000)
(defparameter *initial-state* 0 "initial state number")

; **** structure for vertex
(defstruct (state-vertex (:conc-name nil))
    state			; state number  e.g. 4
    par-symbol			; e.g. (3 5)
    )
(defstruct (symbol-vertex (:conc-name nil))
    category     	; e.g. NP
    node-ptr		; e.g. 3
    par-state		; e.g. (3 5)
    start-position	; e.g. 13 start word position of the left most symbol
    			;         add 5/26/87 to pack every packable ambiguity
    )
; 
(defstruct (node (:conc-name nil))
    node-category		; e.g. NP
    sons			; e.g. ((4 5 6) (7 8 9))
    value			; unified value
)


; **** structure for active-list
(defstruct active-vertex
    vertex-number		; state node pointer
    state			; state number
    action			; list of actions e.g. ((re . 3)(sh . 5))
    )

;  debug 
(defvar *debug-level* 0)	; if it is 1, print rule application
    				; if it is 2, also print rules killed
    				; if it is greater than 2, only programmar
				; understand the output.

(defvar *debug-out* t)		; where to output the debugging information

(defvar *debug-applied*)	; whether this rule has been applied or not
				; used in "reduce-one" and "apply-rule".

(defvar *debug-par-sons-list*)	; par-son nodes to display node number 8/17/87
    				; in dmode.  Used in reduce-one, apply-rule,
				; and disp-rule. List of (par son1 son2...).

(defvar *debug-killed-sons*) ; 9/9/87
; array-func.lisp

(defun init-array ()
    (setq *state-array* (make-array *initial-vertex-size*
			     :adjustable t
			     :fill-pointer t))
    (setf (fill-pointer *state-array*) 0)
    (setq *symbol-array* (make-array *initial-vertex-size*
			     :adjustable t
			     :fill-pointer t))
    (setf (fill-pointer *symbol-array*) 0)
    (setq *node-array* (make-array *initial-node-size*
			     :adjustable t
			     :fill-pointer t))
    (setf (fill-pointer *node-array*) 0)
)

; push-state
(defun push-state (state-number par-symbol)
    (let ((a-vertex (make-state-vertex :state state-number
			               :par-symbol par-symbol)))
	 (when (>= *debug-level* 3)
	       (format *debug-out* "~& push state ~A (node# ~A)"
		       (state a-vertex)
		       (fill-pointer *state-array*)))
	 (vector-push-extend a-vertex *state-array*)  ; return value
    ))
; push-symbol
(defun push-symbol (category node-ptr par-state-list start-position)
    (let ((a-symbol (make-symbol-vertex :category category
			 :node-ptr node-ptr :par-state par-state-list
			 :start-position start-position)))
	 (when (>= *debug-level* 4)
	       (format *debug-out* "~& push symbol ~A" a-symbol))
	 (when (= *debug-level* 3)
	       (format *debug-out*
		       "~& push symbol ~A (node# ~A) from state node# ~A"
		       (category a-symbol)
		       (fill-pointer *symbol-array*)
		       (par-state a-symbol)))
	 (vector-push-extend a-symbol *symbol-array*)  ; return value
    ))

; push-node
(defun push-node (category sons value)
    (let ((a-node (make-node :node-category category
			 :sons sons :value value))
	  node-no)
	 (setq node-no (vector-push-extend a-node *node-array*))
	 (when (>= *debug-level* 4)
	       (format *debug-out* "~& push node #~D" node-no))
	 node-no
    ))

; push-symbol-node  push a symbol and a node
(defun push-symbol-node (category par-state sons value word-position)
    (push-symbol category (push-node category sons value)
	 par-state word-position))

; add-par-state
(defun add-par-state (parent symbol)
    (when (= *debug-level* 3)
	  (format *debug-out*
		  "~& add par state ~A (node# ~A) to symbol ~A (node# ~A)"
		  (state (state-array parent)) parent
		  (category (symbol-array symbol))  symbol))
    (setf (par-state (aref *symbol-array* symbol))
	  (append (par-state (aref *symbol-array* symbol))
		  (list parent))))

; add-par-symbol
(defun add-par-symbol (parent state)
    (when (= *debug-level* 3)
	  (format *debug-out*
		  "~& add par symbol ~A (node# ~A) to state ~A (node# ~A)"
		  (category (symbol-array parent))  parent
		  (state (state-array state)) state))
    (setf (par-symbol (aref *state-array* state))
		  (append (par-symbol (aref *state-array* state))
			  (list parent))))

; delete-par-symbol
(defun delete-par-symbol (a-parent state)
    (when (= *debug-level* 3)
	  (format *debug-out*
		 "~& delete par symbol ~A (node# ~A) from state ~A (node# ~A)"
		 (category (symbol-array a-parent))  a-parent
		 (state (state-array state)) state))
    (setf (par-symbol (aref *state-array* state))
	  (remove a-parent (par-symbol (state-array state)))
    ))

; append-new-ambiguity  symbol2 will die.
; 5-Aug-87  for failure recovery, add "when sons are not equal" condition.
(defun append-new-ambiguity (symbol1 symbol2)
    (let ((node1 (node-ptr (symbol-array symbol1)))
	  (node2 (node-ptr (symbol-array symbol2))))
	 
	 (when (listp (node-category (node-array node2))) ; it's already merged
	       (return-from append-new-ambiguity nil))
	 (when (>= *debug-level* 3)
	       (format *debug-out* "~& packing ~A(~D) to ~D"
		       (node-category (node-array node2)) node2 node1))
	 (when (or (not *parser-failed*)     ; when failed, do not pass here
		   (not (equal (sons (node-array node1))
			       (sons (node-array node2))))
		   (not (equal (value (node-array node1))
			       (value (node-array node2)))))
	       (setf (sons (aref *node-array* node1))
		     (append (sons (node-array node1))
			     (sons (node-array node2))))
	       (if *new-unify*
		   (setf (value (aref *node-array* node1))  ; then
			 (append-value node1 node2))
		   (setf (value (aref *node-array* node1))  ; else
			 (append (value (node-array node1))
				 (value (node-array node2))))
	       ))
	 (setf (node-category (aref *node-array* node2))
	       (list (node-category (aref *node-array* node2))
		     'is 'merged 'to node1))
	 ; to see to which it was merged
    ))

; append-value
; 10/20/87 changed to display warning message when *warn-ambiguous-grammar*
;          is t    
(defun append-value (node1 node2)
    (let ((x (value (node-array node1))) (y (value (node-array node2)))
	  list-x list-y double-value)
	 (if (eq (car x) '*OR*)
	     (setq list-x (cdr x))  ; then
	     (setq list-x (list x))) ; else
	 (if (eq (car y) '*OR*)
	     (setq list-y (cdr y))  ; then
	     (setq list-y (list y))) ; else
;;;	 (format t  "~&~a ~a" list-x list-y)
	 (cond ((and *warn-ambiguous-grammar*
		    (setq double-value (have-same-value list-x list-y)))
		(disp-ambiguous-warn node1 node2 double-value)
		(cons '*or* (no-duplicate (append list-x list-y))))
	       (t (cons '*or* (append list-x list-y))))
    ))
			     
(defun disp-ambiguous-warn (node1 node2 double-value)
    (format *out* "~& node ~d and node ~d contain the same value:~&  ~d"
	    node1 node2 double-value)
)
; have-same-value
(defun have-same-value (x y)
    (dolist (a x nil)
	    (when (member a y :test #'equal)
		  (return a))))
    
; no-duplicate
(defun no-duplicate (list)
    (do ((rest list (cdr rest))
	 (return-val nil)
	 (a))
	((null rest) (reverse return-val))
	(setq a (car rest))
	(if (dolist (b return-val t)
		    (if (equal a b)
			(return nil)))
	    (setq return-val (cons a return-val)))
    ))

; state-array
(defun state-array (n)
    (aref *state-array* n))

; symbol-array
(defun symbol-array (n)
    (aref *symbol-array* n))

; node-array
(defun node-array (n)
    (aref *node-array* n))
; load-grammar.lisp   load data and make grammar tables
(defun load-grammar (gra)
   (format *out* "~& loading parsing tables~&")
   (load (concatenate 'string gra "_25"))
   (format *out* " loading funcitons~&")
   (load (concatenate 'string gra "_fun"))
   (format *out* " initializing tables~&")
   (make-tables)
   (format *out* "~& Parser ready for ~A" gra)
   (values)
)

#|
(defun loadgra (gra)	;; changed for v7.5 by mt 5/30/87
   (format *out* "~& loading parsing tables~&")
   (load (concatenate 'string gra "_tg33.tab"))
   (format *out* " loading funcitons~&")
   (load (concatenate 'string gra "_funload.lisp"))
   (format *out* " initializing tables~&")
   (make-tables)
   (format *out* "~& Parser ready for ~A" gra)
   (values)
)
(defun loadgra-fast (gra)
   (format *out* "~& loading parsing tables~&")
   (load (concatenate 'string gra "_25.lisp"))
   (format *out* " loading funcitons~&")
   (load (concatenate 'string gra "_fun.fasl"))
   (format *out* " initializing tables~&")
   (make-tables)
   (format *out* "~& Parser ready for ~A" gra)
   (values)
)
|#

(defun load-data (gra)
    (load-grammar gra))

;;(defun initialize ()
;;    (init-array)
;;    (list (make-active-vertex
;;	       :vertex-number (push-state *initial-state* nil)
;;	       :state *initial-state*
;;	       :action nil))
;;)
; main.lisp
(defun parse (&optional (string *text*) &aux ans)
    (let (list)
	 (setq *parse-number* (1+ *parse-number*))
	 (format *out* "~3&>~a~&" string)
	 (setq list (append (stringtolist string) '($)))
	 (setq ans
	       (if *ignore-space*
		   (parse-list (remove '| | list)) ; then
		   (parse-list (one-space list))))  ; else
	 (and *semantics* *parse-value*
	      (lessp 0 *max-amb-sem-display*)
	      (disp-sem-amb *parse-value* *max-amb-sem-display*))
	 ans
    ))

(defun parse-list (text)
    (setq *parser-failed* nil)
    (do ((active-list (initialize))
	 (rest-of-text text (cdr rest-of-text))
	 (lookahead)
	 (parsed-part nil)	; display when failed
	 (start-time (get-internal-real-time))
	 (time-spent)
	 (word-position 1 (1+ word-position))
	 (active-before-reduce)	; active at the beginning of the session
	)
	((null rest-of-text) nil)	; return
	(setq lookahead (car rest-of-text))
	(setq *active-killed* nil) ; see fill-actions
	(setq active-before-reduce active-list)
	; For failure recover. Remembers which verteces are killed during
	; the session handling this lookahead.  Will be updated by function
	; fill-actions
	(setq active-list
	      (fill-actions active-list lookahead))  ; of active list
	(when (>= *debug-level* 3)
	      (format *out* "~& ~a ~a" lookahead active-list))
	(cond ((and (not *ignore-space*)
		    (punctuation-p lookahead))
	       (when (eq *space-character* lookahead)
		     (setq rest-of-text (cdr rest-of-text))
		     (setq lookahead (car rest-of-text)))
	       (setq active-list (reduce-all active-list lookahead))
	       (setq active-list (merge-state active-list)))
	      (*ignore-space*
		      (setq active-list (reduce-all active-list lookahead))
		      (setq active-list (merge-state active-list)))
	      (t (setq active-list (remove-action active-list *reduce*))))
	(when (null active-list)
	      ; failure. no reduce or no shift after reduce found
	      (setq *parser-failed* t)
	      (unless *recover-from-failure*  ; need not to recover
		      (display-fail-message parsed-part rest-of-text)
		      (setq *parse-value* nil)
		      (return-from parse-list nil)) ;; ***** exit
	      (multiple-value-setq (active-list rest-of-text)
		  (recover-failure active-before-reduce rest-of-text))
	      (setq lookahead (car rest-of-text)))
	(when (eq lookahead '$)
	      (setq time-spent (- (get-internal-real-time) start-time))
	      (cond ((all-accept active-list)
		     (if (not *parser-failed*)
			 (return-from parse-list         ;; ****** exit
				(disp-value active-list time-spent))
			 (return-from parse-list         ;; ****** exit
				(disp-value (append-so-far active-list)
				     time-spent))))
		    (t (return-from parse-list	     ;; ****** exit
			      (disp-value active-list time-spent)))))
	(setq active-list (shift-all active-list lookahead word-position))
	(when (>= *debug-level* 1)
	      (format *out* "~&~a~%" lookahead))
	(setq parsed-part (cons lookahead parsed-part))
    ))


(defun initialize ()
    (setf (fill-pointer *state-array*) 0)
    (setf (fill-pointer *symbol-array*) 0)
    (setf (fill-pointer *node-array*) 0)
    (list (make-active-vertex
	       :vertex-number (push-state *initial-state* nil)
	       :state *initial-state*
	       :action nil))
)

; fill-actions
(defun fill-actions (active-list lookahead)
    (let (action (return-active active-list))
	 (dolist (an-active active-list return-active)
		 (setq action
		       (get-action (active-vertex-state an-active) lookahead))
		 (cond ((null action)
			(setq return-active
			      (remove-from an-active return-active))
;;;;			(format t "~& add active-killed ~a" an-active)
			(setq *active-killed*
			      (cons an-active *active-killed*)))
		       		; *active-killed* is initiallized by the 
				; funciton parse-list at the
				; beggining of the session which handles a
				; particular word (or character)
				; and keeps the active-verteces
				; which are killed during the seccsion
		       (t (setf (active-vertex-action an-active)
				action)))
	 )))

; reduce-all
; inp e.g. ( (1 5 (sh . 4)) (1 5 (re . 3)) (2 10 (sh . 3)))  (structures)
; return all shift active list
(defun reduce-all (active-list lookahead)
    (when (null active-list)
	  (return-from reduce-all nil))
    (let ((return-active active-list))
	 (do ((a-reduce t)	; exit when this is nil.
	      (new-active-list))
	     ((null a-reduce) return-active)  ; returns all shift active list
	     (multiple-value-setq
		 (a-reduce new-active-list)
		 (pickup-reduce return-active))
	     (when a-reduce
		   (setq return-active
			 (reduce-one a-reduce new-active-list lookahead)))
	     (when (>= *debug-level* 3)
		   (format *out* "~& ~a ~a" lookahead
			   return-active))
	 )))

; pickup-reduce   pick up a reduce action from the active vertex list
;    	          and also returns the rest of the active list.
; e.g. ((1 5 ((sh . 4) (re . 3))) (2 10 (re . 4)))
;	  --> (1 5 (re . 3)) and ((1 5 ((sh . 4))) (2 10 (re . 4)))
(defun pickup-reduce (active-list)
    ; first find the "right most reduce"
    (let (the-reduce the-active (max-word-position 0)
	  new-actions return-active copy)
	 (do ((rest-active active-list (cdr rest-active))
	      (an-active))
	     ((null rest-active) nil)
	     (setq an-active (car rest-active))
	     (do ((rest (active-vertex-action an-active) (cdr rest))
		  (an-action) (word-position))
		 ((null rest) nil) 
		 (setq an-action (car rest))
		 (when (eq *reduce* (first an-action))  ; a reduce found
		       (setq word-position
			     (get-right-most (active-vertex-vertex-number
						    an-active)))
;;;;;;;;;;;	       (format t "~& word-position= ~D ~&an-active=~a"
;;;;;;;;;;;	       word-position an-active)
		       (when (> word-position max-word-position)
			     (setq max-word-position word-position)
			     (setq the-reduce an-action)
			     (setq the-active an-active))
		 )))
	 (cond ((= max-word-position 0) (values nil active-list))
	       (t (setq new-actions
			(remove-from the-reduce
			       (active-vertex-action the-active)))
;;;;;;;;;;;;;;;;  (format t "~& chosen ~D" max-word-position)
		  (cond ((null new-actions)
			 (setq return-active
			       (remove-from the-active active-list)))
			(t (setf (active-vertex-action the-active)
				 new-actions)
			   (setq return-active active-list)))
		  (setq copy  (copy-active-vertex the-active))
		  (setf (active-vertex-action copy) (list the-reduce))
		  (values copy return-active))
	 )))

; get-right-most
(defun get-right-most (vertex-number)
    (do ((rest (par-symbol (state-array vertex-number)) (cdr rest))
	 (a-symbol) (word-pos 0))
	((null rest) word-pos)
	(setq a-symbol (car rest))
	(if (> (first (start-position (symbol-array a-symbol))) word-pos)
	    (setq word-pos (first (start-position (symbol-array a-symbol)))))
    ))

; remove-from remove "s-exp" from "list"
(defun remove-from (s-exp list)
    (do ((rest list (cdr rest))
	  (head nil)
	  (return-list nil))
	((null rest) (reverse return-list))
	(setq head (car rest))
	(unless (equal s-exp head)
		(setq return-list (cons head return-list)))
    ))

; remove-reduce
(defun remove-action (active-list kind)
    (do ((rest-active active-list (cdr rest-active))
	 (an-active) (return-active nil) (actions-left))
	((null rest-active) return-active)
	(setq an-active (car rest-active))
	(setq actions-left
	      (do ((rest (active-vertex-action an-active) (cdr rest))
		   (an-action)(new-actions nil))
		  ((null rest) new-actions)
		  (setq an-action (car rest))
		  (when (not (eq kind (first an-action)))
			(setq new-actions (cons an-action
						new-actions)))))
	(when actions-left
	      (setf (active-vertex-action an-active)
		    actions-left)
	      (setq return-active
		    (cons an-active return-active)))
    ))

; merge-state
;  Merge right-most states that have the same state numbers.
;  Returns the new (merged) active list.    
;  The merged one will be removed from he active list.
;  The variable pairs is an assoc list of (state-number vertex-number) pair.
;  called after all the reduce actions are completed.
(defun merge-state (active-list)
    (do ((rest active-list (cdr rest))
	 (an-active) (return-active nil)
	 (pairs nil)       ;   assoc list of (state vertex-number)
	 (the-pair))
	((null rest) (reverse return-active))  ; *** return
	(setq an-active (car rest))
	(cond ((setq the-pair (assoc (active-vertex-state an-active) pairs))
		 ; if the active-vertex has the same state number as the-pair,
	       (remove-from an-active active-list)
	       	; for each parent symbol of the state vertex to be deleted,
		; add it to the parent symbol list of the-pair vertex.
	       (do ((rest-sym (par-symbol
				  (state-array (active-vertex-vertex-number
						      an-active)))
			 (cdr rest-sym)))
		   ((null rest-sym) nil)
		   (add-par-symbol (car rest-sym) (second the-pair))))
	      (t (setq pairs 	; else add it to the assoc list
		       (cons (list (active-vertex-state an-active)
				   (active-vertex-vertex-number an-active))
			     pairs))
		 (setq return-active (cons an-active return-active)))
	)))
    
; all-accept   ((94 44 (ac)) (97 22 (ac)))    -->  t
(defun all-accept (active-list)
    (if (null active-list)
	nil
	(dolist (an-active active-list t)
		(when (null (active-vertex-action an-active))
		      (return-from all-accept nil))
		(dolist (an-action (active-vertex-action an-active) t)
			(unless (eq *accept* (car an-action))
				(return-from all-accept nil))
		))))

; disp-value
(defun disp-value (active-list time)
    (do ((rest (par-symbol (state-array (active-vertex-vertex-number
					       (first active-list))))
	       (cdr rest)) 	; there should be one active vertex.
	 (value-list) (disp-values) (big) (small))
	((null rest)
	 (if *parse-return-value*
	     value-list    ;; to pass values for generation  -- sem jul18
	     (values)))
	(setq value-list
	      (value (node-array
			  (node-ptr (symbol-array (car rest))))))
	(if (and *new-unify* (eq (car value-list) '*OR*))
	    (setq value-list (cdr value-list))   ; then
	    (setq value-list (list value-list))) ; else
	(setq disp-values (no-duplicate value-list))
	(setq *parse-value* disp-values)
	(cond (*parser-failed*
		      (format *out*
			      "~2& *** failed but recoved and got the following ***~&"))
	      ((> (length value-list) 1)
	       (format *out* "~2& ~D (~D) ambiguities found and"
			 (length value-list) (length disp-values)))
	      (t
	       (format *out* "~2& ~D (~D) ambiguity found and"
			 (length value-list) (length disp-values))))
	       
	(multiple-value-setq (big small)
	    (floor time internal-time-units-per-second))
	(format *out* " took ~D.~D seconds of real time"
		big small)
	(when (>= *debug-level* 2)
	      (format *out* "~&node # ~D~&"
		      (node-ptr (symbol-array (car rest)))))
	(when (and (not *parser-failed*)
		   (> (length disp-values) *max-ambiguity-display*))
	      (format *out* "~& Will display only ~a values."
		      *max-ambiguity-display*)
	)
	(cond (*parser-failed*
		      (terpri)(pprint (car (last disp-values))))
	      (t (do ((rest-val disp-values (cdr rest-val))
		      (number 1 (1+ number)))
		     ((or (> number *max-ambiguity-display*) (null rest-val))
		      nil)
		     (format *out* "~2&;**** ambiguity ~d ***~%" number)
		     (pprint (car rest-val))
		     (terpri)))
	)
    ))

; display-fail-message
(defun display-fail-message (parsed-part rest-of-text)
    (format *out* "~2& failed")
    (format *out* "~& parsed --> ~A~& rest   --> ~A~&"
	    (reverse parsed-part) rest-of-text)
)


; reduce.lisp
; reduce   reduce one active vertex and reuturns newly-born vertex(es)
(defun reduce-one (a-reduce active-list lookahead)
    (let ((rule (get-rule (cdr (first (active-vertex-action a-reduce)))))
	  return-val)
	 (setq *debug-applied* nil)   ; These two vars are used for dmode
	 (setq *debug-par-sons-list* nil)
	 (setq return-val
	       (backmove-to-symbol
		   (active-vertex-vertex-number a-reduce)
		   active-list (first rule) (second rule) (third rule)
		   nil lookahead nil))
	 (disp-rule a-reduce rule); for dmode. display rules applied
	  			  ; (and killed)
	 return-val
    ))

; backmove-to-symbol  return newly born actives during the session.
(defun backmove-to-symbol (state active-list rule-left rest-rule-right
				 func sons lookahead word-position-list)
    (do ((rest-par (par-symbol (state-array state)) (cdr rest-par))
	 (return-actives active-list)
	 (a-parent))
	((null rest-par) return-actives)
	(setq a-parent (car rest-par))
	(setq return-actives
	      (backmove-to-state a-parent return-actives
		  rule-left rest-rule-right func sons lookahead
		  (cons (start-position (symbol-array a-parent))
			 word-position-list)))
    ))

; backmove-to-state
(defun backmove-to-state (symbol active-list rule-left rest-rule-right func
				 brothers lookahead word-position-list)
    (cond ((null (cdr rest-rule-right))
	   (apply-rule symbol active-list rule-left func
		 (cons (node-ptr (symbol-array symbol)) brothers) lookahead
		 word-position-list)
	  )
	  (t
	    (do ((rest-par (par-state (symbol-array symbol)) (cdr rest-par))
		 (return-actives active-list)
		 (a-parent))
		((null rest-par) return-actives)
		(setq a-parent (car rest-par))
		(setq return-actives
		      (backmove-to-symbol a-parent return-actives rule-left
			  (cdr rest-rule-right) func
			  (cons (node-ptr (symbol-array symbol)) brothers)
			  lookahead word-position-list)
		)))
    ))

; disp-rule
; display rules applied or killed with node numbers.
(defun disp-rule (a-reduce rule)
    (when (and (>= *debug-level* 2) *debug-applied*)
	  (format *debug-out* "~& rule #~4D ~15A"
		  (cdr (first (active-vertex-action a-reduce)))
		  (third rule))
	  (do ((rest-apply (unique (reverse *debug-par-sons-list*))
		    (cdr rest-apply))
	       (left-node) (right-nodes)(a-reduce)(left-category)
	       (first-line t))
	      ((null rest-apply) nil)
	      (setq a-reduce (car rest-apply))
	      (setq left-node (car a-reduce))
	      (setq right-nodes (cadr a-reduce))
	      (setq left-category (node-category (node-array left-node)))
	      (cond (first-line (setq first-line nil))
		    (t (format *debug-out* "~&~27A" '| |)))
	      ; **** write left hand side of the rule ****
	      (cond ((listp left-category)
		     (format *debug-out* " ~A(~d, was ~d) --> "
			     (car left-category)
			     (car (last left-category))
			     left-node))
		    (t (format *debug-out* " ~A(~D) --> "
			       left-category left-node)))
	      ; **** write right hand side of the rule ****
	      (do ((rest-right right-nodes (cdr rest-right))
		   (a-node))
		  ((null rest-right) nil)
		  (setq a-node (car rest-right))
		  (cond ((not (sons (node-array a-node)))
			 (format *debug-out* "~A"
				 (node-category (node-array a-node))))
			(t	(format *debug-out* "~A(~D) "
					(node-category (node-array a-node))
					a-node)))
	      )))
    (when (and (>= *debug-level* 2) (not *debug-applied*))
	  (format *debug-out* "~& killed - rule # ~D ~A"
		  (cdr (first (active-vertex-action a-reduce)))
		  (third rule))
	  (format *debug-out* "  ~A -->" (car rule))
	  (dolist (a *debug-killed-sons*)
		  (format *debug-out* " ~a(~d)"
			  (node-category (node-array a)) a)))
)
; file name -- apply.lisp
; apply-rule
(defun apply-rule (symbol active-list rule-left func sons lookahead
			  word-position-list)
    (let (value new-node)
	 (cond ((null func) (setq value nil))
	       (t (setq value (get-value func sons))
		  (when (null value)
			(setq *debug-killed-sons* sons)
			(return-from apply-rule active-list)))) ; killed
	 (setq new-node (push-node rule-left (list sons) value))
	 ;;;	 (format t "~& value = ~A" value)
	 (do ((rest-par (par-state (symbol-array symbol))
		   (cdr rest-par))
	      (a-parent) (new-state-no) (adding-actives nil)
	      (merge-to) (new-symbol)(new-active) (prev-symbol))
	     ((null rest-par) (append active-list adding-actives)) ; return
	     
	     (setq a-parent (car rest-par))
	     (setq new-state-no
		   (get-goto-state (state (state-array a-parent)) rule-left))
	     (setq *debug-applied* 1) ; will be used in reduce-one
	     (cond ((setq merge-to (same-destination new-state-no
					adding-actives lookahead))
		    ; notice the value is the same with one of the prev. ones
		    ; case go to the same state.
		    ;         O\(one of par-states already processed)
		    ;           * -- O(new-state-no)
		    ;         O/(a-par-state)
		    ; where '*' is the symbol currently being processed.
		    (setq prev-symbol
			  (car (par-symbol (state-array merge-to))))
		    (add-par-state a-parent prev-symbol)
		   )
		   (t (setq new-symbol
			    (push-symbol rule-left new-node
				 (list a-parent)
				 (list (caar word-position-list)
				       (caar (last word-position-list)))))
;;;;;		      (format t "~& *** new-symbol = ~d *** " new-symbol)
		      (setq *debug-par-sons-list* ; to print rule application
			    (cons (list (node-ptr (symbol-array new-symbol))
					sons)
				  *debug-par-sons-list*))
		      (unless (ambiguity-packing new-symbol active-list
				  new-state-no lookahead)
			      (setq new-active
				    (make-active-vertex
					 :vertex-number
					 (push-state new-state-no
					      (list new-symbol))
					 :state new-state-no
					 :action nil))
			      (setq adding-actives
				    (append adding-actives
					    (fill-actions (list new-active)
						 lookahead))))))
	 )))

; same-destination
;     see if the same state number appears in the active list.
;     return the state-vertex-number or nil
(defun same-destination (state-no active-list lookahead)
;;    (when (eq *failure-lookahead* lookahead)
;;	  (return-from same-destination state-no))
    (do ((rest active-list (cdr rest))
	 (an-active))
	((null rest) nil)
	(setq an-active (car rest))
	(when (and (= state-no (active-vertex-state an-active))
		   (equal (active-vertex-action an-active)
			  (get-action state-no lookahead))
	      )
	      (return (active-vertex-vertex-number an-active)))
    ))
; ambiguity-packing
;    1. see if the new-symbol is packable to another symbol
;       (the same destination, the same origin and the same category)
;    2. merge them into the node
;   return node to which it merged if packed; return nil otherwise.
;   8/5/87 add no-dupulicate son check for failure recovery
(defun ambiguity-packing (new-symbol active-list new-state-no lookahead)
    (if (and *no-ambiguity-packing*
	     (not (eq (category (aref *symbol-array* new-symbol))
		      *start-symbol*)))
	(return-from ambiguity-packing nil))
    (do ((rest active-list (cdr rest))  ; check for each active
	 (an-active)
	 (left-state0 (car (par-state (symbol-array new-symbol))))
	    ; origin state of the adding symbol. must be only 1 element list.
	 (right-state))
	((null rest) nil)
	(setq an-active (car rest))
	(when (setq right-state ; the same destination?
		    (same-destination new-state-no (list an-active)
			 lookahead))
	      
	      (do ((rest-par-sym (par-symbol (state-array right-state))
			(cdr rest-par-sym))
		   (a-par-symbol))
		  ((null rest-par-sym) nil)
		  (setq a-par-symbol (car rest-par-sym))
		  (when (equal (category (symbol-array a-par-symbol))
			       (category (symbol-array new-symbol)))
			; found a symbol with the same category
			; So check whether it has the same origin.
			(do ((rest-par (par-state
					   (symbol-array a-par-symbol))
				  (cdr rest-par))
			     (a-left-state))
			    ((null rest-par) nil)
			    (setq a-left-state (car rest-par))
			    (when (equal left-state0 a-left-state)
				  ; origin is also the same

				  (when (and *parser-failed*
					     (already-in new-symbol
						     a-par-symbol))
					(return-from ambiguity-packing t))
				  ; ** exit
				  ; if parser failed and
				  ; when sons are the same then do not want to
				  ; add too many sons,
				  ; so just return t. No one uses the returned
				  ; value. must not return nil.
				  
				  (append-new-ambiguity
					 a-par-symbol new-symbol)
				  (delete-par-symbol new-symbol right-state)
			;;;	  (setf (fill-pointer *symbol-array*)
			;;;		(1- (fill-pointer *symbol-array*)))
				  (return-from ambiguity-packing
					 a-par-symbol))
			)))
	)))

; different-value
;;(defun different-value (node1 node2)
;;    (not (equal (value (node-array node1))
;;		(value (node-array node2)))))


; get-value
(defun get-value (func sons)
    (if (null func)
	'no-function         	;  then
	(apply func (mapcar #'value (mapcar #'node-array       ; else
					    sons)))))
(defun already-in (new-symbol par-symbol)
    (let (new-sons par-son-list new-node)
	 (setq new-node (node-ptr (symbol-array new-symbol)))
	 (setq new-sons (car (sons (node-array new-node))))
	 (setq par-son-list
	       (sons (node-array (node-ptr (symbol-array par-symbol)))))
	 (dolist (a par-son-list nil)
		 (when (equal a new-sons)
		       (setf (node-category (aref *node-array* new-node))
			     (list (category (symbol-array new-symbol))
				   'is 'the 'same 'as
				   (node-ptr (symbol-array par-symbol))))
		       (return t))
	 )))
; shift-all
;  ( (1 5 (sh . 4)) (1 5 (sh . 3)) (2 10 (sh . 3))) --> ((3 7 nil)(5 12 nil))
(defun shift-all (active-list lookahead word-position)
    (do  ((rest active-list (cdr rest))
	  (new-active-list nil)
	  (right-states nil)  ; assoc ((state-number vertex-number))
	  (an-active))
	 ((null rest) new-active-list)    ; return
	 (setq an-active (car rest))
;;	 (if (> (length (active-vertex-action an-active)) 1)
;;	     (format t "~&~a" (active-vertex-action an-active)))
	; the following is to accept shift-shift conflict
	 (do ((shifts-left (active-vertex-action an-active) (cdr shifts-left))
	      (right-state-number)
	      (same-state))
	     ((null shifts-left) nil)
	     (setq right-state-number
		   (cdr (car shifts-left)))
	     (cond ((setq same-state ; goto the same state after shift
			  (second (assoc right-state-number
					 right-states)))
		    (add-par-state (active-vertex-vertex-number an-active)
			(first (par-symbol (state-array same-state))))
		   )
		   (t				; else
		       (multiple-value-bind (new-active pair)
			   (simple-shift
				  (active-vertex-vertex-number an-active)
				  lookahead right-state-number word-position
				  (first (car shifts-left)))
			   (push pair right-states)
			   (push new-active new-active-list)
		       ))
	     ))))

; simple-shift    shift a symbol and a state.
; returns a new active vertex and (state-no vertex) assoc list
; add kind to distinguish sh (*shift*) and sh* (*wild-card-shift*)

(defun simple-shift (left-vertex lookahead right-state-number word-position
			 kind)
    (let (new-symbol right-vertex node-value)
	 (if (equal kind *wild-card-shift*)
	     (setq node-value			; then
		   (list (list 'value lookahead)))
	     (setq node-value nil))		; else
	 (setq new-symbol (push-symbol-node lookahead
			       (list left-vertex) nil node-value
			       (list word-position word-position)))
	 (setq right-vertex (push-state right-state-number (list new-symbol)))
	 (values (make-active-vertex
		      :vertex-number right-vertex
		      :state right-state-number
		      :action nil)  ;to be filled later
		 (list right-state-number right-vertex)
	 )))
; table-func.lisp   making talbes and access functions
; **** make grammar table, action table and goto table **** 
; mk-ary  for compatibility with previous version programmed by ITI people
(defun mk-ary ()
    (make-tables))
(defun make-tables ()
    (make-grammar-table)
    (make-action-table)
    (make-goto-table)
    (setq *gg* nil
	  *a-tab*  nil
	  *g-tab*  nil)
    (init-array)
    t
)

(defun make-grammar-table ()
    (let ((dim (length *gg*)) )
      (setq *grammar-table* (make-array dim :initial-contents *gg*))
      (setq *start-symbol* (caar *gg*))
      nil))

; make-action-table
; 6/22/87  add make-reduce-union-table for failure recovery
(defun make-action-table ()
    (let ((dim (1+ (caar (last *a-tab*)))))
	 (setq *action-table* (make-array dim))
	 (dolist (arg *a-tab*)
		 (setf (aref *action-table* (car arg)) (cdr arg)))
	 (make-reduce-union-table dim)
    ))

; make-reduce-union-table
; 06/18/87   add for recovery from failure
; This is not necessary for LR 0 algorithm, however, this parser is supposed
; to be used for both LR 0 and LR 1, so ...    
(defun make-reduce-union-table (dim)
    (setq *reduce-union-table* (make-array dim))
    (do ((i 0 (1+ i))
	 (reduce-union))
	((equal dim i) nil)
	(setq reduce-union nil)
	(do ((rest (aref *action-table* i) (cdr rest))
	     (pair))
	    ((null rest) nil)
	    (setq pair (car rest))
	    (unless (eq (first pair) *reduce-action-character*)
		    (do ((rest-action (cdr pair) (cdr rest-action))
			 (an-action))
			((null rest-action) nil)
			(setq an-action (first rest-action))
			(when (and (equal (first an-action) *reduce*)
				   (not (member (cdr an-action) reduce-union)))
			      (setq reduce-union (cons (cdr an-action)
						       reduce-union)))))
	)
	(setf (aref *reduce-union-table* i) reduce-union)
    ))


(defun make-goto-table ()
    (let ((dim (1+ (caar (last *g-tab*))) ))
      (setq *goto-table* (make-array dim))
      (dolist (arg *g-tab*)
	(setf (aref *goto-table* (car arg)) (cdr arg))) ))

; get-action
; e.g.  (get-action 2 'noun)  -->  ((sh . 10) (re . 3))
;       (get-action 2 *failure-lookahead*)    -->  ((re . 3) (re . 4))
; 6/22/87  to treat failure recovery add *failure-lookahead* testing
; 
(defun get-action (state-number lookahead)
    (when (= -1 state-number)  	; for eronious goto table entry 7/29/87
	  (return-from get-action nil))	       ; **** return
    (when (eq lookahead *wild-card-character*)
	  (return-from get-action              ; **** return
		 (cdr (assoc lookahead (aref *action-table* state-number)))))
    (when (eq lookahead *failure-lookahead*)  ; usually '$$   see declaration
	  (return-from get-action
		 (do ((rest (aref *reduce-union-table* state-number)
			    (cdr rest))
		      (result nil))
		     ((null rest) result)   ; *** return value
		     (setq result (cons (cons *reduce* (car rest)) result))
		 )))
    ;  normal case
    (let (normal (wild-actions nil) wild)
	 (setq normal
	       (append (cdr (assoc lookahead
				   (aref *action-table* state-number)))
		       (cdr (assoc *reduce-action-character*
				   (aref *action-table* state-number)))
	       ))
	 
	 (when (not (or (eq lookahead '$)
			(member lookahead *wild-card-stop-characters*)))
	       (setq wild-actions
		     (cdr (assoc *wild-card-character*
				 (aref *action-table* state-number)))))
	 (when wild-actions	; if wild card appear here ...
	       (setq wild
		     (do ((rest wild-actions (cdr rest))
			  (new nil)(an-action))
			 ((null rest) (reverse new))
			 (setq an-action (car rest))
			 (if (equal *shift* (car an-action))
			     (setq new (cons (cons *wild-card-shift*
						   (cdr an-action)) new))
			     (setq new (cons an-action new)))
		     )))
	 (append normal wild)
    ))

; get-goto-state
;  (get-goto 0 '<S>)   --> 5
(defun get-goto-state (state-number symbol)
    (let ((return-val
		 (cdr (assoc symbol (aref *goto-table* state-number)))))
	 (when (null return-val)
	       (when (>= *debug-level* 1)
		     (format t "~& ** Error in goto table.")
		     (format t " Kill this node. **"))
	       (setq return-val -1))
	 return-val
    ))

; get-rule
;  (get-rule 1)   -->   (<S> (<NP> <VP>) F-1)
(defun get-rule (rule-number)
    (aref *grammar-table* (1- rule-number))
)
; util.lisp
; stringtolist
(defun stringtolist (string)
    (let ((list nil) (upstring (string-upcase string)))
	 (dotimes (i (length upstring) (reverse list))
	     (push (change-type (char upstring i)) list)
	 )))

(defun change-type (ch)    ; ch must be "character" type
    (cond
	 ((digit-char-p ch)
	  (digit-char-p ch))
	 (t
	   (intern (string ch)))
    ))

(defun one-space (list)
    (do ((rest list (cdr rest))
	 (return-val nil)
	 (prev nil) (char))
	((null rest) (reverse return-val))
	(setq char (car rest))
	(cond ((eq '| | char)
	       (unless (eq *space-character* prev)
		       (push *space-character* return-val)))
	      (t (setq return-val (push char return-val))))))

(defun disp-array (&optional (name nil))
    (let ((list (list name)))
	 (when (null (car list))
	       (setq list '(*node-array* *symbol-array* *state-array*)))
	 (when (eq name 'node)
	       (do ((i 0 (1+ i)))
		   ((eq i (fill-pointer *node-array*)) t)
		   (format *debug-out*
			   "~&~a category = ~a sons = ~a"
			   i (node-category (aref *node-array* i))
			   (sons (aref *node-array* i))))
	       (return-from disp-array))
	 (when (eq name 'node-value)
       	       (setq list '(*node-array*)))
	 (when (eq name 'symbol)
       	       (setq list '(*symbol-array*)))
	 (when (eq name 'state)
       	       (setq list '(*state-array*)))
	 (dolist (a list (values))
		 (format *debug-out* "~&*** ~A ***" a)
		 (do ((i 0 (1+ i)))
		     ((eq i (fill-pointer (eval a))) t)
		     (format *debug-out* "~&~a ~a" i (aref (eval a) i))
		 ))))

; disp-tree
(defun disp-tree (&optional (start-node (1- (fill-pointer *node-array*))))
    (when (and (not *recover-from-failure*) *parser-failed*)
	  (let ((temp *debug-level*))
	       (setq *debug-level* 0)
	       (append-so-far *active-killed*)
	       (setq start-node (1- (fill-pointer *node-array*)))
	       (setq *debug-level* temp)))
;;;    if merged
;;;    (if (listp (node-category (aref *node-array* start-node)))
;;;	(setq start-node
;;;	      (car (last (node-category (aref *node-array* start-node))))))
    (disp-tree-sub start-node 0))


(defun disp-tree-sub (node tab)
    (let ((sons-list (sons (node-array node)))
	  category)
	 (when sons-list
	       (format *debug-out* "~&")
	       (dotimes (i tab)
		   (format *debug-out* " "))
	       (setq category (node-category (node-array node)))
	       (cond ((listp category)
		      (format *debug-out* " ~a(~d, merged to ~a) -->"
			      (car category) node (car (last category))))
		     (t (format *debug-out* " ~a(~d) -->"
				category node)))
	       (dolist (a-set-of-sons (list (car sons-list)) (values))
		       (dolist (a-son a-set-of-sons nil)
			       (if (sons (node-array a-son))
				   (format *debug-out* " ~a(~d)"   ; then
					   (node-category (node-array a-son))
					   a-son)
				   (format *debug-out* " ~a"   ; else
					   (node-category (node-array a-son)))
			       ))
		       (dolist (a-son a-set-of-sons)
			       (disp-tree-sub a-son (+ 4 tab)))
		       (format *debug-out* "~&")
	       ))
    ))

; disp-nodes  display nodes for debugging for grammar writers etc.
(defun disp-nodes (&optional (disp-value? nil))
    (dotimes (i (fill-pointer *node-array*) (values))
	(let ((cat (node-category (node-array i))))
	     (when (sons (node-array i))  ; and it is not a terminal
		   (cond ((listp cat)
			  (format *debug-out* "~& ~3@a  ~a(merged to ~a) --> "
				  i (car cat) (car (last cat))))
			 (t (format *debug-out* "~& ~3@a  ~a --> "
				    i cat)))
		   (disp-nodes-sub (sons (node-array i)))
		   (if disp-value?
		       (format *debug-out* "~&     ~a"
			       (value (node-array i))))
	     ))))

; disp-nodes-sub    for packed nodes
(defun disp-nodes-sub (sons-list)
    (cond ((> (length sons-list) 1) 	; if packed node
	   (do ((rest sons-list (cdr rest)))
	       ((null rest) nil)
	       (format *debug-out* "(")
	       (do ((rest-sons (car rest) (cdr rest-sons)))
		   ((null rest-sons) nil)
		   (format *debug-out* "~a"
			   (node-category (node-array (car rest-sons))))
		   (if (sons (node-array (car rest-sons)))
		       (format *debug-out* "~a" (car rest-sons)))
		   (if (cdr rest-sons) (format *debug-out* " ")))
	       (format *debug-out* ")")
	       (if (cdr rest) (format *debug-out* " or "))))
	  (t (dolist (a-set-of-sons sons-list)
		     (dolist (a-son a-set-of-sons)
			     (format *debug-out* "~a"
				     (node-category (node-array a-son)))
			     (if (sons (node-array a-son))
				 (format *debug-out* "~a" a-son))
			     (format *debug-out* " ")
		     )))
    ))
(defun disp-node-value (i)
    (format *debug-out* "~&category = ~a~&sons = ~a~&value ="
	    (node-category (node-array i)) (sons (node-array i)))
    (pprint (value (node-array i))))

(defun p (text)
    (progn (parse text)
	   (values)))

(defun p* (sentences)
    (do ((rest sentences (cdr rest))
	 (a-sent) (i 1 (1+ i)))
	((null rest) (values))
	(setq a-sent (car rest))
	(format *out* "~2& sentence # ~D" i)
	(p a-sent)))

(defun dmode (&optional (mode nil))
    (if mode
	(setq *debug-level* mode)  ; then
	*debug-level*)		   ; else
)

(defun pa ()
    (format t "~&>")
    (setq *text* (read-line))
    (parse)
)

; unique
(defun unique (list)
    (do ((rest list (cdr rest))
	 (a)
	 (return-value nil))
	((null rest) (reverse return-value))
	(setq a (car rest))
	(do ((rest-sub return-value (cdr rest-sub)))
	    ((null rest-sub) (setq return-value (cons a return-value)))
	    (when (equal a (car rest-sub))
		  (return nil))
	)))

(defun disp-def (file-name number)
    (let ((inp (open (concatenate 'string file-name ".gra")
		     :direction :input))
	  def)
	 (do ((i 0))
	     ((eq i number))
	     (setq def (read inp))
	     (unless (or (eq (second def) '-->)
			 (eq (second def) '==>))
		     (setq i (1+ i))))
	 (format *debug-out* "~&(~a ~a ~a" (first def)(second def)
		 (third def))
	 (do ((rest (fourth def) (cdr rest))
	      (first t) (l))
	     ((null rest))
	     (setq l (car rest))
	     (cond (first (format *debug-out* "~&~8t(")
			  (setq first nil))
		   (t 	 (format *debug-out* "~&~9t")))
	     (cond ((or (eq '*or* (car l))(eq '*and* (car l)))
		    (format *debug-out* "(~a~16t~a" (car l) (cadr l))
		    (dolist (a (cddr l))
			    (format *debug-out* "~&~16t~a" a))
		    (format *debug-out* ")"))
		   (t (format *debug-out* "~a" l)))
	     (when (null (cdr rest))
		   (format *debug-out* "))")))
	 (close inp)
	 (values)
    ))

; punctuation-p
(defun punctuation-p (char)
    (or (eq char *space-character*)
	(eq char '$)
	(eq char '|'|)
	(eq char '|"|)
	(eq char '|.|)
	(eq char '|:|)
	(eq char '|;|)
	(eq char '|?|)
	(eq char '|!|)
    ))
; recover.lisp
; recover-failure
(defun recover-failure (initial-active-list rest-of-text)
    (when (>= *debug-level* 1)
	  (format *out* "~& ***  Parser faild.  will recover  ***"))
    (let ((active-list initial-active-list))
	 ; will reduce as far as possible even if the lookahead is incorrect.
;;;	 (print *active-killed*)
	 (when (not *active-killed*)
	       ; if no rules have been applied
	       (setq active-list  ; get reduce actions
		     (fill-actions active-list *failure-lookahead*))
	       (reduce-all active-list *failure-lookahead*)
	       ; no need to save this value. What we need is the actives
	       ; which were killed during the reduce.
	       ; During the reduce actions, all the verteces killed are added
	       ; to *active-killed* by function fill-actions.
	 )
	 (setq active-list (merge-state (reverse *active-killed*)))
	 ;;;	 (format t "~& active-killed = ~A" *active-killed*)
	 (setq active-list (append-so-far active-list))
	 (find-restart-point active-list rest-of-text)
    ))

; append-so-far
; append the values of the verteces on the left of the current actives
(defun append-so-far (active-list)
    (do ((rest-active active-list (cdr rest-active))
	 (an-active) (adding-active nil))
	((null rest-active) adding-active)
	(setq an-active (car rest-active))
	;;;;	(print adding-active)
	(setq adding-active
	      (backmove-to-symbol-fail
		  (active-vertex-vertex-number an-active)
		  adding-active
		  nil nil nil))  ; sons, value and word-pos-list
	(when (and adding-active
		   (>= (number-of-sons adding-active)
		       *number-of-failure-abmiguity*))
	      (return-from append-so-far adding-active))
	;; If you rescue too many paths, it takes too mach time.
	;; So we only rescue *number-of-failure-ambiguity* paths.    
	
    ))
	 

; backmove-to-symbol-fail
; back to a symbol vertex from a state vertex
(defun backmove-to-symbol-fail (state adding-active sons value
				      word-position-list)
    (cond ((null (par-symbol (state-array state)))
	   (when (and adding-active
		      (>= (number-of-sons adding-active)
			  *number-of-failure-abmiguity*))
		 (return-from backmove-to-symbol-fail adding-active))
	   ;; If you rescue too many paths, it takes too mach time.
	   ;; So we only rescue *number-of-failure-ambiguity* paths.    
	   
	   (when (>= *debug-level* 2)
		 (format *debug-out* "~& apply ~a --> ~a"
			 *fail-symbol* (mapcar #'node-category
					       (mapcar #'node-array sons))))
	   (let (new-symbol)
		(setq new-symbol
		      (push-symbol-node
			   *fail-symbol* (list state) (list sons) value
			   (list (caar word-position-list)
				 (caar (last word-position-list)))))
		(cond ((ambiguity-packing new-symbol adding-active
			   *initial-state* *failure-lookahead*)
		       ; then no need to add it to active
		       adding-active)
		      (t    ; else add it
			    (cons (make-active-vertex
				       :vertex-number
				       (push-state *initial-state*
					    (list new-symbol))
				       :state *initial-state*
				       :action nil)
				  adding-active)))))
	  (t (do ((rest-par (par-symbol (state-array state)) (cdr rest-par))
		  (a-parent) (return-val adding-active))
		 ((null rest-par) return-val)
		 (setq a-parent (car rest-par))
		 (setq return-val
		       (backmove-to-state-fail a-parent return-val
			   sons value
			   (cons (start-position
				       (symbol-array a-parent))
				 word-position-list)))
		 (when (and return-val
			    (>= (number-of-sons return-val)
				*number-of-failure-abmiguity*))
		       (return-from backmove-to-symbol-fail return-val))
		 ;; If you rescue too many paths, it takes too mach time.
		 ;; So we only rescue *number-of-failure-ambiguity* paths.    
	     )
	  )))

; number-of-sons
(defun number-of-sons (adding-active)
    (let ((an-active (car adding-active))   ; must be one state. ( from <??> )
	  par-symbol)
	 (setq par-symbol          ; must be one par-symbol <??>
	       (car (par-symbol (state-array (active-vertex-vertex-number
						    an-active)))))
	 (length (sons (node-array (node-ptr (symbol-array par-symbol)))))
    ))

; backmove-to-state-fail
(defun backmove-to-state-fail (symbol adding-active sons value
				      word-position-list)
    (do ((rest-par (par-state (symbol-array symbol)) (cdr rest-par))
	 (return-val adding-active) (a-parent)
	 (new-sons))
	((null rest-par) return-val)
	(setq a-parent (car rest-par))
;;;	(setq node-value
;;;	      (value (node-array (node-ptr (symbol-array symbol)))))
	
	; We do not want to add nodes with value t or nil
;;;	(if (or (null node-value) (eq t node-value))
;;;	    (setq new-sons sons)      ; then
;;;	    (setq new-sons	      ; else
;;;		  (cons (node-ptr (symbol-array symbol)) sons))

	    (setq new-sons
		  (cons (node-ptr (symbol-array symbol)) sons))
	
	(setq return-val
	      (backmove-to-symbol-fail
		  a-parent return-val
		  new-sons
		  (get-value-union
		      (value (node-array
				  (node-ptr
				       (symbol-array symbol))))
		      value)
		  word-position-list))
    ))

; get-value-union
(defun get-value-union (value1 value2)
    (cond ((or (null value1) (eq t value1))
	   (return-from get-value-union (list value2)))
	  
	  ((or (null value2) (eq t value2))
	   (return-from get-value-union (list value1)))
	  
	  (t (cons value1 value2)))
)

; find-restart-point
(defun find-restart-point (active-list rest-of-text)
    (do ((rest rest-of-text (cdr rest))
	 (lookahead)(temp-active-list))
	((equal '$ (car rest)) (values active-list rest))
	(setq lookahead (car rest))
	(setq temp-active-list (fill-actions active-list lookahead))
	(when temp-active-list ; a shiftable element found
	      (setq *active-killed* nil)
	      (return (values temp-active-list rest)))
	(when (>= *debug-level* 1)
	      (format *out* "~& -- skip ~a" lookahead))
    ))
;;; -*- mode: lisp; syntax: common-lisp; package: unify; base: 10 -*- ;;;

;;; Update record
;;;
;;; knight:
;;;
;;; 3/7/88  Fixed lfg-compiler to notice inconsistent rule definitions.
;;;         Fixed unifier to fail on unification of atomic and complex
;;;	      structures.
;;;

;;;----------------------------------------------------------------------
;;; DAG-STRUCT.LISP
;;;----------------------------------------------------------------------

;; This file contains structure definitions for graphs, nodes, and arcs.
;; Also included are print functions, constructor functions, 
;; de-constructor functions, copier functions, accessor functions,
;; and modifier functions.

;; STRUCTURES

(defstruct (graph-node (:print-function print-graph-node))
	class
	subnodes
	mark
	mfset)

(defstruct (arc (:print-function print-arc))
	type
	label
	destination)

;; NODE-CLASSES

(defconstant *kb-top* '[])
(defconstant *kb-bottom* '[I])

;; ARC-TYPES

(defconstant *normal* '=)
(defconstant *must-be-present* '=c)
(defconstant *multiple-valued* '>)

;; PRINT FUNCTIONS

(defun print-graph-node (n &rest ignore)
  (princ (graph->fs n)))

  ;(if (null (graph-node-subnodes n))
      ;(format *standard-output* 
              ;"#<Graph-Node-Atomic, CLASS: ~A>" 
;	      (graph-node-class n))
;      (format *standard-output* 
;              "#<Graph-Node-Complex, CLASS:  ~A, ARCS:  ~A>" 
;	      (graph-node-class n)
;	      (graph-node-arc-labels n))))

(defun print-arc (a &rest ignore)
  (format *standard-output* 
          "#<Graph-Arc, TYPE: ~A, LABEL: ~A>" 
          (arc-type a) 
	  (arc-label a)))

;; MEMORY MANAGEMENT

(defvar *graph-node-pool* nil)
(defvar *graph-arc-pool* nil)

;; CONSTRUCTORS

(defun create-graph-node (&key (class *kb-top*)
			 (subnodes nil)
			 (mark nil)
			 (mfset nil))
  (let ((n (or (pop *graph-node-pool*) (make-graph-node))))
    (setf (graph-node-class n) class)
    (setf (graph-node-subnodes n) subnodes)
    (setf (graph-node-mark n) mark)
    (setf (graph-node-mfset n) (or mfset (list n)))
    n))

(defun create-arc (&key (label nil)
			(type *normal*)
			(destination nil))
  (let ((n (or (pop *graph-arc-pool*) (make-arc))))
    (setf (arc-label n) label)
    (setf (arc-type n) type)
    (setf (arc-destination n) destination) 
    n))

(defun create-null-graph () (create-graph-node))

;; DE-CONSTRUCTORS

(defun dispose-graph-node (node) 
  (when (not (member node *graph-node-pool*))
        (push node *graph-node-pool*)))

(defun dispose-arc (arc) 
  (when (not (member arc *graph-arc-pool*))
        (push arc *graph-arc-pool*)))
        
(defun dispose-graph (node)
  (mapc #'dispose-graph-node (nodes-in-graph node)))

;; COPIERS

(defun copy-graph-node (node)
  (create-graph-node :class (graph-node-class node)
	       :subnodes (graph-node-subnodes node)
	       :mark (graph-node-mark node)
	       :mfset (graph-node-mfset node)))

(defun copy-arc (arc)
  (create-arc  :label (arc-label arc)
	       :type (arc-type arc)
	       :destination (arc-destination arc)))

(defun copy-graph (node)
  (let* ((n1 (nodes-in-graph node)))
    (mapc #'(lambda (n) (setf (graph-node-mark n) (create-null-graph))) n1)
    (mapc #'(lambda (n)
	      (setf (graph-node-class (graph-node-mark n)) 
		    (copy-tree (graph-node-class n)))
	      (setf (graph-node-mark (graph-node-mark n)) nil)
	      (setf (graph-node-mfset (graph-node-mark n)) 
		    (if (mf-root-class? n) 
			(mapcar #'graph-node-mark (graph-node-mfset n))
			(graph-node-mark (graph-node-mfset n))))
	      (setf (graph-node-subnodes (graph-node-mark n))
	            (mapcar #'(lambda (a) 
				(create-arc
				  :type (arc-type a)
				  :label (arc-label a)
				  :destination 
				    (graph-node-mark (arc-destination a))))
			    (graph-node-subnodes n))))
          n1)
    (graph-node-mark node)))

;; ACCESSORS

;; (defun graph-node-class (n) ...)
;; (defun graph-node-subnodes (n) ...)
;; (defun graph-node-mark (n) ...)
;; (defun graph-node-mfset (n) ...)
;; (defun arc-type (a) ...)
;; (defun arc-label (a) ...)
;; (defun arc-destination (a) ...)

(defun graph-node-arc (node label)
  (find label (graph-node-subnodes node) 
        :key #'(lambda (a) (arc-label a))))

(defun graph-node-subnode (node label)
  (arc-destination (graph-node-arc node label)))

(defun graph-node-arc-labels (node)
  (mapcar #'arc-label (graph-node-subnodes node)))

;; MODIFIERS

;; (setf (graph-node-class n) ...)
;; (setf (graph-node-subnodes n) ...)
;; (setf (graph-node-mark n) ...)
;; (setf (graph-node-mfset n) ...)
;; (setf (arc-type a) ...)
;; (setf (arc-label a) ...)
;; (setf (arc-destination a) ...)

(defun add-arc (node arc)
  (unless (graph-node-arc node (arc-label arc))
    (push arc (graph-node-subnodes node))))

(defun add-arc-in-order (node arc)
  (unless (graph-node-arc node (arc-label arc))
    (setf (graph-node-subnodes node)
          (merge 'list (list arc) (graph-node-subnodes node)
            #'(lambda (x y) (string< (string (arc-label x)) 
				     (string (arc-label y))))))))

;;;----------------------------------------------------------------------
;;; DAG-FNS.LISP
;;;----------------------------------------------------------------------

;; This file contains various functions over dag structures.

;;
;; Function MARK-GRAPH
;;
;; Takes a root node of a graph and a marker.  Sets the mark field of 
;; every node in the graph equal to the marker.  Uses a gensym'd 
;; temporary marker name.

(defun mark-graph-1 (node sym)
  (when (not (eq (graph-node-mark node) sym))
        (setf (graph-node-mark node) sym)
        (mapc #'(lambda (a) (mark-graph-1 (arc-destination a) sym))
	      (graph-node-subnodes node))))

(defun mark-graph (node mark)
  (let ((marker (gensym "MARKER-")))
    (mark-graph-1 node marker)
    (mark-graph-1 node mark)))

;;
;; Function DEPTH-FIRST-TRAVERSAL
;;
;; Takes a root node of a graph and returns a list of nodes in the
;; graph.  Assumes that all nodes begin with MARK = NIL.

(defun depth-first-traversal (node) 
  (setf (graph-node-mark node) t)
  (cond ((null (graph-node-subnodes node)) (list node))
        (t (cons node
                 (mapcan #'(lambda (n) 
                              (if (null (graph-node-mark n)) 
                                  (depth-first-traversal n) 
                                  nil))
                         (mapcar #'arc-destination 
				 (graph-node-subnodes node)))))))

;;
;; Function NODES-IN-GRAPH
;;
;; Takes a root node of a graph and returns a list of all nodes in
;; the graph.  Uses a standard marking procedure to avoid traversing the
;; same portion of the graph more than once.

(defun nodes-in-graph (node)
  (mark-graph node nil)
  (depth-first-traversal node))

;;;----------------------------------------------------------------------
;;; DAG-PRINT.LISP
;;;----------------------------------------------------------------------

;; This file contains functions to read and write arbitrary graphs.
;; Graphs are coded as lists with variables to mark reentrancy.  Thus,
;; graph structures can effectively (1) be printed on the the screen, 
;; and (2) be written to files and read back in.

(defvar *dag-variables*
  '($0000 $0001 $0002 $0003 $0004 $0005 $0006 $0007 $0008 $0009
    $0010 $0011 $0012 $0013 $0014 $0015 $0016 $0017 $0018 $0019
    $0020 $0021 $0022 $0023 $0024 $0025 $0026 $0027 $0028 $0029
    $0030 $0031 $0032 $0033 $0034 $0035 $0036 $0037 $0038 $0039
    $0040 $0041 $0042 $0043 $0044 $0045 $0046 $0047 $0048 $0049
    $0050 $0051 $0052 $0053 $0054 $0055 $0056 $0057 $0058 $0059))

;; Function GRAPH->FS
;;
;; Takes a dag-structure and returns a tree in list format.  Loses
;; reentrancy of dag (copies are made).  Possibly useful for converting 
;; dag structure into standard f-structure that is used in other 
;; modules of the MT project.

(defun graph->fs (d)
  (cond ((null (graph-node-subnodes d)) (graph-node-class d))
        (t (mapcar #'(lambda (a) (list (arc-label a) 
                                       (graph->fs (arc-destination a))))
   	           (graph-node-subnodes d)))))

;; Function F-STR-TYPE
;;
;; Return the type of an f-structure stored in tree (s-expression) format.

(defun f-str-type (t1)
  (cond ((atom t1) :atomic)
	(t (case (car t1)
	     (*OR* (if (atom (cadr t1)) 
                       :atomic-disjunction :complex-disjunction))
	     (*NOT* (if (atom (cadr t1))
		        :atomic-negation :complex-negation))
	     (*MULT* (if (atom (cadr t1))
	                :atomic-multiple-value :complex-multiple-value))
	     (otherwise :complex)))))

;; Function FS->GRAPH
;;
;; Takes a tree in list format (standard f-structure format) and returns 
;; a dag-structure.  The structure will of course have no reentrancy.

(defun fs->graph (t1)
 (let ((k (f-str-type t1)))
  (cond ((member k (list :atomic :atomic-disjunction
			 :atomic-negation :atomic-multiple-value))
	 (create-graph-node :class t1 :subnodes nil))
	((eq k :complex)
         (let ((n (create-graph-node :class *kb-top* :subnodes nil)))
              (mapc #'(lambda (a) 
                        (add-arc-in-order n
                           (create-arc 
          		     :label (car a) 
			     :type *normal*
                             :destination (fs->graph (cadr a)))))
                    t1)
              n))
	((eq k :complex-disjunction)
	 (create-graph-node :class *kb-top*
                      :subnodes (cons '*OR* 
				      (mapcar #'(lambda (n) (fs->graph n)) 
				              (cdr t1)))))
	((eq k :complex-negation)
	 (create-graph-node :class *kb-top*
                      :subnodes (cons '*NOT*
				      (mapcar #'(lambda (n) (fs->graph n)) 
				              (cdr t1)))))
	((eq k :complex-multiple-value)
	 (create-graph-node :class *kb-top*
                      :subnodes (cons '*MULT*
				      (mapcar #'(lambda (n) (fs->graph n)) 
				              (cdr t1))))))))

;; Function GRAPH->PRINT
;;
;; Takes a dag-structure and returns a dag coded in list format.
;; For each node in the dag-structure, there is a corresponding element
;; in the list.  Each element has the form:
;;
;;      (<node-variable> <node-class> <node-subnodes>)
;; 
;; The order of elements corresponds to the order of a depth-first
;; traversal of the dag-structure.  If the arcs of the nodes are
;; ordered lexicographically, each dag-structure will have a well-defined
;; canonical list-format code.

(defun graph->print (d)
  (let ((n (nodes-in-graph d)))
    (mapc #'(lambda (n1 dv) (setf (graph-node-mark n1) (list dv))) 
          n *dag-variables*)
    (mapc #'(lambda (p)
	      (setf (graph-node-mark p)
	            (append
		      (graph-node-mark p)
		      (list (graph-node-class p))
		      (list 
                       (mapcar 
                        #'(lambda (a)
			    (list (arc-label a) 
				  (arc-type a)
                                  (car (graph-node-mark (arc-destination a)))))
		        (graph-node-subnodes p))))))
          n)
    (mapcar #'graph-node-mark n)))

;; Function PRINT->GRAPH
;;
;; Takes a dag coded in list format and returns a dag-structure.
;; (The list format code described above is decoded back into a 
;; structure).  This function orders the arcs leaving a node 
;; lexicographically, so that exactly the same structure will appear
;; no matter how many times it is coded and decoded.

(defun print->graph (dp) 
  (let ((n (mapcar #'(lambda (n1) (create-graph-node :mark n1)) dp)))
    (mapc #'(lambda (p)
 	      (setf (graph-node-mfset p) nil)
	      (setf (graph-node-class p) (second (graph-node-mark p)))
              (mapc 
		#'(lambda (a)
		    (add-arc-in-order 
		      p
	 	      (create-arc 
			:label (first a)
			:type (second a)
			:destination 
			  (find (third a) n 
				:key #'(lambda (x) (car (graph-node-mark x)))))))
	  	(third (graph-node-mark p))))
          n)
    (car n)))

;;;----------------------------------------------------------------------
;;; DAG-MFSET.LISP
;;;----------------------------------------------------------------------

;; This file contains functions for performing disjoint set operations
;; on dag nodes.

;; Function MF-ROOT-CLASS?
;;
;; Takes a node and returns T if the node is the root of its equivalence
;; class tree.

(defun mf-root-class? (n) (listp (graph-node-mfset n)))

;; Function MF-FIND
;;
;; Performs the FIND operation for UNION-FIND disjoint sets.  Given
;; a node in a dag-structure, it returns another node, namely the root 
;; of the equivalence class tree for the input node.  After the FIND,
;; the tree is made more shallow by adjustment of pointers to the root.
  
(defun mf-find (x)
  (do ((q1 nil) (t1 x))
      ((mf-root-class? t1)                ; do path compression
       (progn () 
              (mapc #'(lambda (n) (setf (graph-node-mfset n) t1)) q1) 
              t1))
      (push t1 q1)
      (setq t1 (graph-node-mfset t1))))

;; Function MF-UNION
;;
;; Performs the UNION operation for UNION-FIND disjoint sets.  Given
;; two nodes in dag-structures, it joins their equivalence class trees
;; and returns the new root.  Smaller trees are merged into larger ones,
;; helping keep balance.

(defun mf-union (x y) 
  (let ((x1 (mf-find x)) 
        (y1 (mf-find y)))
    (if (eq x1 y1)             ; already in the same equivalence class
        x1
        (cond ((< (length (graph-node-mfset x1)) (length (graph-node-mfset y1)))   
	       (setf (graph-node-mfset y1) 
		     (nconc (graph-node-mfset y1) (graph-node-mfset x1)))
       	       (setf (graph-node-mfset x1) y1)
	       y1)
	      (t
	       (setf (graph-node-mfset x1)
		     (nconc (graph-node-mfset x1) (graph-node-mfset y1)))
	       (setf (graph-node-mfset y1) x1)
	       x1)))))
 
;; Function MF-INIT
;;
;; Takes the root of a dag-structure and initializes the graph for
;; UNION-FIND operations.  Each node is essentially placed into a
;; singleton equivalence class.

(defun mf-init (x)
  (mapc #'(lambda (n) (setf (graph-node-mfset n) (list n)))
        (nodes-in-graph x)))

;; Function CREATE-RESULT-GRAPH
;;
;; Takes a dag-structure in which some of the nodes may have been
;; UNION'd together.  Returns a new dag-structure in which nodes in
;; the same equivalence classes have been merged together into single
;; nodes.  All of the nodes in the result graph are allocated anew.
;;
;; This function is used in the LFG compiler, in the incremental creation
;; of dag-structures from rule augmentations.

(defun create-result-graph (classes)
  (mapc #'(lambda (n)
	    (mapc #'(lambda (a) 
			(setf (arc-destination a)
			      (mf-find (arc-destination a))))
	          (graph-node-subnodes n)))
        classes)
  (car classes))

(defun create-result-graph-1 (d)
  (let* ((nodes (nodes-in-graph d))
         (classes (remove-if-not #'mf-root-class? nodes))
         (res (create-result-graph classes)))
    (mapc #'dispose-graph-node (set-difference nodes classes))
    res))

(defun create-result-graph-2 (d1 d2)
  (let* ((nodes (let ((n1 (nodes-in-graph d1))
	              (n2 (nodes-in-graph d2)))
	             (append (list (car n1) (car n2))
                             (cdr n1)
          	             (cdr n2))))
	 (classes (remove-if-not #'mf-root-class? nodes))
	 (res (create-result-graph classes)))
    (mapc #'dispose-graph-node (set-difference nodes classes))
    res))

;;;----------------------------------------------------------------------
;;; DAG-DISJ.LISP
;;;----------------------------------------------------------------------

;; Function EXPAND-DISJUNCTIONS
;;
;; Takes a set of equations -- a rule augmentation -- and creates several
;; sets of equations -- several rule augmentations -- by removing
;; complex disjunctions.

(defun expand-disjunctions (equations)
 (cond ((not (assoc '*OR* equations)) (list equations))
       (t (let ((disj (assoc '*OR* equations)))
	       (mapcan
	         #'(lambda (d)
		       (expand-disjunctions (append d (remove disj equations))))
	         (cdr disj))))))

;;;----------------------------------------------------------------------
;;; DAG-LFG.LISP
;;;----------------------------------------------------------------------

;; This file contains functions for translating LFG-like rules into
;; dag-structures.

;; Function RULE->GRAPH
;;
;; Takes an LFG rule and returns a dag-structure for that rule.

(defun rule->graph (eqns)
  (let ((d (create-graph-node :class *kb-top* :subnodes nil)))
    (dolist (eqn eqns)
      (let* ((lhs (first eqn))
	     (rhs (third eqn))
	     (eqn-type (if (eq rhs '*DEFINED*)
			   *must-be-present* (second eqn))))
           (if (and (member (f-str-type rhs)
			    (list :atomic :atomic-disjunction 
		                  :atomic-negation :atomic-multiple-value))
                    (not (member rhs *register-variables*)))
	       (let ((k (create-graph-path d lhs eqn-type)))
                    (cond ((graph-node-subnodes k) (setq d nil) (return nil))
			  ((equal (graph-node-class k) *kb-top*)
                           (setf (graph-node-class k) rhs))
                          (t (setq d nil) (return nil))))
	       (let* ((n1 (create-graph-path d
				       (if (atom lhs) (list lhs) lhs)
				       (if (eq eqn-type *must-be-present*)
				           eqn-type *normal*)))
	              (n2 (create-graph-path d 
				       (if (atom rhs) (list rhs) rhs) 
				       eqn-type))
	              (n3 (mf-union n1 n2)))
		     (if (eq n1 n3)
		   	 (carry-labels n2 n1)
		         (carry-labels n1 n2))))))
    (if (null d) nil (create-result-graph-1 d))))

;; Function CREATE-PATH
;;
;; Takes a node in a dag-structure and a path from an equation in an
;; LFG rule.  Elements in the path correspond to arcs taken in the
;; dag-structure.  The node at the end of the path is returned.  If
;; at some point, the path calls for an arc which does not exist,
;; a new arc is created, along with a new node for it to point to.

(defun create-graph-path (node path eqn-type)
  (cond 
    ((null path) node)
    (t (let ((a (graph-node-arc node (car path))))
	    (cond ((null a) 
		   (let ((n1 (create-graph-node :class *kb-top*)))
                        (add-arc-in-order 
                          node 
			  (create-arc :label (car path)
				      :type (cond ((not (eq eqn-type 
                                                            *multiple-valued*))
       						   eqn-type)
                                                  (t (if (= (length path) 1)
							 *multiple-valued*
							 *normal*)))
				      :destination n1))
		        (create-graph-path n1 (cdr path) eqn-type)))
                  (t 
		   (cond ((eq eqn-type *must-be-present*)
                          (setf (arc-type a) *must-be-present*))
			 ((and (eq eqn-type *multiple-valued*)
                               (= (length path) 1)) 
                          (setf (arc-type a) *multiple-valued*)))
 		   (create-graph-path (arc-destination a) 
				(cdr path) 
				eqn-type)))))))

;; Function RULE->GRAPHS
;;
;; Takes a rule and returns a list of dag structures by first expanding
;; out all of the disjunctions in the rule equations and then converting
;; equation sets into dags.

(defun rule->graphs (rule)
  (remove nil (mapcar #'rule->graph (expand-disjunctions rule))))

;;;----------------------------------------------------------------------
;;; DAG-KB.LISP
;;;----------------------------------------------------------------------

;; This file contains a knowledge base (inheritance hierarchy) used to test
;; the Ait-Kaci-style unification routine, which makes use of inheritance
;; information.  The functions here are only for test purposes: they are 
;; very inefficient.
;;
;; The functionality provided here can be provided by any knowledge
;; representation system, e.g. FrameKit.  Here is what is needed:
;; a knowledge base with top element '[] and bottom element '[I];
;; and the function "greatest-lower-bound". 
;;
;; "Greatest-lower-bound" must return exactly one element from the KB;
;; if there is not greatest-lower-bound, then it must return '[I].
;;

(defconstant kb
 '(([] person witch monarch)
   (person adult child)
   (adult teenager)
   (child teenager)
   (teenager [I])
   (witch wicked-queen)
   (monarch queen)
   (queen wicked-queen)
   (wicked-queen [I])
   ([I])))

(defun includes-1 (c1)
  (append (cdr (assoc c1 kb))
          (mapcan #'includes (cdr (assoc c1 kb)))))

(defun includes (c1)   				  ; all concepts below c1
  (cons c1 (remove-duplicates (includes-1 c1))))

(defun is-included-by (c1)			  ; all concepts above c1
  (remove-if #'(lambda (x) (not (ancestor? x c1)))
             (mapcar #'car kb)))
  
(defun ancestor? (c1 c2) 
  (member c2 (includes c1)))
(defun proper-ancestor? (c1 c2)
  (and (ancestor? c1 c2) (not (eq c1 c2))))
(defun descendent? (c1 c2) 
  (ancestor? c2 c1))
(defun proper-descendent? (c1 c2)
  (proper-ancestor? c2 c1))

(defun greatest-lower-bound (c1 c2) 
  (cond ((eq c1 *kb-top*) c2)
	((eq c2 *kb-top*) c1)
        ((eq c1 c2) c1)
        ((or (not (member c1 (mapcar #'car kb)))
             (not (member c2 (mapcar #'car kb)))) *kb-bottom*)
        (t (let ((x (intersection (includes c1) (includes c2))))
                (dolist (n x)
                  (if (notany #'(lambda (p) (and (proper-ancestor? p n))) x)
                      (return n)))))))

(defun least-upper-bound (c1 c2) 
  (cond ((eq c1 *kb-bottom*) c2)
	((eq c2 *kb-bottom*) c1)
        ((eq c1 c2) c1)
        ((or (not (member c1 (mapcar #'car kb)))
             (not (member c2 (mapcar #'car kb)))) *kb-top*)
        (t (let ((x (intersection (is-included-by c1) (is-included-by c2))))
                (dolist (n x)
                  (if (notany #'(lambda (p) (and (proper-descendent? p n))) x)
                      (return n)))))))

;;;----------------------------------------------------------------------
;;; DAG-UNIFY.LISP
;;;----------------------------------------------------------------------

;; This file contains functions for unifying two dag-structures.

;; Constants. 

(defconstant *register-variables*
  '(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15
    x16 x17 x18 x19 x20 x21 x22 x23 x24 x25))

;; Function MAKE-CONSTITUENT-GRAPH
;;
;; Takes a list of pairs: ((label dag-structure) (label dag-structure) ...),
;; hooks all of them together.  

(defun make-constituent-graph (d-list) 
  (let ((n (create-graph-node :class *kb-top* :subnodes nil)))
    (mapc #'(lambda (d)
              (add-arc-in-order n (create-arc :label (car d) 
					      :type *normal*
					      :destination (cadr d))))
          d-list)
    n))

;; Function MAKE-CONSTITUENT-GRAPHS
;;
;; Takes a list of pairs: ((label dag-structures) (label dag-structures) ...),
;; hooks all of them together.  Returns several graphs by 
;; cross-multiplying.

(defun make-constituent-graphs (d-list)
  (let ((graphs (cross-multiply (mapcar #'cadr d-list)))
        (labels (mapcar #'car d-list)))
       (mapcar #'make-constituent-graph
	       (mapcar #'(lambda (h) (mapcar #'(lambda (i k) (list k i))
                                             h labels))
                       graphs))))

;; Function X-ZERO-SLOT 
;;
;; Takes a dag-structure and returns a subgraph rooted at the node
;; pointed to by the top level x0 arc.  This is used after unification
;; to isolate the result graph.

(defun x-zero-slot (d)
  (let ((a (graph-node-arc d 'x0)))
       (if (null a) nil (arc-destination a))))
 
;; Function CARRY-LABELS
;;
;; Adds the arcs of n1 to n2.

(defun carry-labels (n1 n2)
  (mapc #'(lambda (l) 
            (let ((a (graph-node-arc n2 (arc-label l))))
                 (if a
                     (when (eq (arc-type a) *normal*)
	                   (setf (arc-type a) (arc-type l)))
	             (add-arc n2 l))))
        (graph-node-subnodes n1)))

;; Functions for testing if a class is atomic or disjunctive, etc.
;;

(defun atomic-class (c) (atom c))
(defun disj-class (c) (and (list c) (eq (car c) '*OR*)))
(defun neg-class (c) (and (list c) (eq (car c) '*NOT*)))
(defun mult-class (c) (and (list c) (eq (car c) '*MULT*)))

;; Function UNIFY-DISJ
;;
;; Unifies two disjunctive classes using an inheritance hierarchy.
;; Involves collecting pairwise GLB's for the two disjunctions.

(defun unify-disj (c1 c2)
  (let ((new-classes nil))
       (dolist (c c1)
         (dolist (d c2)
           (let ((g (greatest-lower-bound c d)))
                (if (and (not (eq g *kb-bottom*))
                         (not (some #'(lambda (x) 
					(eq (greatest-lower-bound g x) g))
                                    new-classes)))
                    (push g new-classes)))))
       (cond ((null new-classes) *kb-bottom*)
             ((= (length new-classes) 1) (car new-classes))
             (t (cons '*OR* new-classes)))))

;; Function UNIFY-CLASSES
;;
;; Unifies two classes using an inheritance hierarchy.  The classes may be 
;; atomic, disjunctive, negated, or multiple.  Here is how we deal with
;; the combinations:
;;
;;		atomic		disj		neg		mult
;;         +------------------------------------------------------------+
;; atomic  |	 (1) 	  |     (2)      |      (3)       |     (4)	|
;;         +------------------------------------------------------------+
;; disj    |  	  x       |	(5)      |	(6)       |     (7)	|
;;         +------------------------------------------------------------+
;; neg     |	  x       |	 x       |	(8)	  |	(9)	|
;;         +------------------------------------------------------------+
;; mult    |	  x       |	 x	 |	 x	  |	(10)	|
;;         +------------------------------------------------------------+
;;
;;*(1)  Take the greatest-lower-bound (GLB) of the two classes.
;;*(2)  Create a new disjunction by taking GLB of atomic class with each
;;        class in the disjunctive class.
;; (3)  Specialize the atomic class in as many ways as possible so as
;;        not to cover the negative classes, creating a new disjunction.
;;*(4)  Add the atomic class to the multiple class.
;;*(5)  Create a new disjunction by taking pairwise GLB's.
;; (6)  Specialize each of the disjunctive classes in as many ways as 
;;        possible so as not to cover the negative classes, creating a new
;; 	  disjunction.
;;*(7)  Add the disjunction as a new member of the multiple class.
;;*(8)  Take the union of the negated classes.
;;*(9)  Ignore the negated class, return the multiple class.
;;*(10) Take the union of the multiple classes.
;;

(defun unify-classes (c1 c2)
  (cond ((and (atomic-class c1) (atomic-class c2)) 
	 (greatest-lower-bound c1 c2))
	((and (atomic-class c1) (disj-class c2))
	 (unify-disj (list c1) (cdr c2)))
	((and (atomic-class c1) (neg-class c2))
	 *kb-bottom*)
	((and (atomic-class c1) (mult-class c2))
	 (cons (car c2) (union (list c1) (cdr c2))))
 	((and (disj-class c1) (atomic-class c2))
	 (unify-disj (cdr c1) (list c2)))
   	((and (disj-class c1) (disj-class c2))
	 (unify-disj (cdr c1) (cdr c2)))
	((and (disj-class c1) (neg-class c2))
	 *kb-bottom*)
	((and (disj-class c1) (mult-class c2))
	 (cons (car c2) (cons c1 (cdr c2))))
	((and (neg-class c1) (atomic-class c2))
	 *kb-bottom*)
	((and (neg-class c1) (disj-class c2))
	 *kb-bottom*)
	((and (neg-class c1) (neg-class c2))
	 (cons (car c1) (union (cdr c1) (cdr c2))))
	((and (neg-class c1) (mult-class c2))
	 c2)
	((and (mult-class c1) (atomic-class c2))
	 (cons (car c1) (union (list c2) (cdr c1))))
	((and (mult-class c1) (disj-class c2))
	 (cons (car c1) (cons c2 (cdr c1))))
	((and (mult-class c1) (neg-class c2))
	 c1)
	((and (mult-class c1) (mult-class c2))
	 (cons (car c1) (union (cdr c1) (cdr c2))))))

;; Function GRAPH-UNIFY
;;
;; Unifies two graphs.  The algorithm incorporates inheritance and is
;; based on the work of Ait-Kaci.  It is a congruence
;; closure algorithm which runs in O(n log n) time, where n is the
;; number of nodes in the input graphs.

(defun graph-unify (d1 d2)
 (let ((e1 (copy-graph d1)) (e2 (copy-graph d2)))
  (do ((pairs (list (cons e1 e2)))
       (current) (u) (v) (newclass) (w))
      ((null pairs) (create-result-graph-2 e1 e2))
    (setq current (pop pairs))
    (setq u (mf-find (car current)))
    (setq v (mf-find (cdr current)))
    (setq newclass (unify-classes (graph-node-class u) (graph-node-class v)))
    (when (eq newclass *kb-bottom*) (return *kb-bottom*))
    (when (or (and 
                   (not (equal (graph-node-class u) *kb-top*))
                   (not (null (graph-node-subnodes v))))
              (and 
                   (not (equal (graph-node-class v) *kb-top*))
                   (not (null (graph-node-subnodes u)))))
          (return *kb-bottom*))
    (setq w (mf-union u v))
    (setf (graph-node-class w) newclass)
    (if (eq w v) 
        (carry-labels u v) 
        (carry-labels v u))
    (mapc #'(lambda (l)
	      (push (cons (graph-node-subnode u l) 
                          (graph-node-subnode v l)) pairs))
          (intersection (graph-node-arc-labels u) 
                        (graph-node-arc-labels v))))))

;; Function FULL-UNIFY
;;
;; Unifies rule graphs with constituent graphs.  (Cross-multiplies).
;; Returns a (possibly empty) list of graphs.

(defun full-unify (rule-graphs constit-graphs)
  (mapcan #'(lambda (g) 
              (let ((r (graph-unify (car g) (cadr g))))
                   (if (eq r *kb-bottom*) 
		       nil 
 	   	       (list (x-zero-slot r)))))
          (cross-multiply (list rule-graphs constit-graphs))))

;; Function CROSS-MULTIPLY 
;;
;; Takes n non-empty lists and produces a list of their 
;; cross-multiplications.

(defun cross-multiply (n-lists)
  (cond ((null (cdr n-lists)) (mapcar #'list (car n-lists)))
        (t (let ((x (cross-multiply (cdr n-lists))))
                (mapcan #'(lambda (g) (mapcar #'(lambda (h) (cons g h)) x))
                        (car n-lists))))))

;;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;

;;;;;
;;;;;          LFG-COMPILER-FULL - Compile LFG grammar into ACFG
;;;;;	       
;;;;;	       The first version (AC7)
;;;;;               by Hideto Kagamida
;;;;;          Modified for the second generation system
;;;;;               by Masaru Tomita
;;;;;	       Modified for Full Unification
;;;;;		    by Kevin Knight
;;;;;

;;;;;          history
;;;;;            ac7
;;;;;              0617 start: by kagamida
;;;;;                20 add: *or*
;;;;;            ac9 5/21/87 by mt
;;;;;            lfg-compiler-full 6/2/87 by mt
;;;;;		 lfg-compiler-full-full 1/22/88 by knight
;;;;;

;;;
;;;	   EXPAND-AUGMENTATION-FULL 
;;;	    rhs-len : the length of right hand side
;;;	    statements : list of LFG equations
;;;        Returns (lambda (x1 x2 ..) ..lisp-code..)
;;;


;;; 
;;; CONSTIT-LIST
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

(defvar *functions*)

(defun collect-registers-full (graphs) 
  (let* ((all-regs (mapcan #'(lambda (graph) 
			       (mapcar #'car (third (car graph))))
                           graphs)))
        (remove 'x0 (remove-duplicates all-regs))))

(defun expand-augmentation-full (rhs-len statements)
  (declare (fixnum rhs-len))
  (let* ((reg-list            (subseq CONSTIT-LIST 1 (1+ rhs-len)))
	 (graph-code 	      (mapcar #'graph->print
  				      (rule->graphs statements)))
	 (used-regs           (collect-registers-full graph-code))
	 (not-used-regs       (set-difference reg-list used-regs))
	 (cons-list           (make-cons-list used-regs)))
    (if (= (length reg-list) (length not-used-regs))
        (append			; if no registers are used, return graph
	  `(lambda ,reg-list)
          `((declare (ignore ,@not-used-regs)))
          `((mapcar #'(lambda (z) (x-zero-slot (print->graph z)))
                    (quote ,graph-code))))
        (append			; otherwise, unify
          `(lambda ,reg-list)
          (when not-used-regs   ; if only some registers are used
  	    `((declare (ignore ,@not-used-regs))))
          `((full-unify 
	      (mapcar #'print->graph (quote ,graph-code))
              (make-constituent-graphs (list ,@cons-list))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;   	LFG-COMPILER-FULL - compile lfg grammar into ACFG and FUN-LIST 
;;;	 an element of ACFG :     (<S> (<NP> <V>) IBMF-34)
;;;	 an element of FUN-LIST : (defun IBMF-34 (..) ...)
;;;	  6/2/87 mt
;;;	  1/22/88 knight
;;;
(defun lfg-compiler-full (gra &key gra-file)	;; used in function names

(let ((fun-list nil) (acfg nil) (count 0))
 (format t "*** LFG Compiler started~%")
 (gensym 0)
 (setq *functions* (make-hash-table))
 (dolist (rule gra)
  (let* ((lhs (first rule))			;; left hand side symbol
	 (rhs (second rule))			;; right hand side symbols
	 (aug (third rule))			;; augmentation
         (graph-name nil) ;; temp
         (graph-code nil) ;; temp
	 (lisp-func				;; generated lisp function
	      (expand-augmentation-full (length rhs) aug))
 	 (func-name				;; find the lisp-func in
	      (gethash lisp-func *functions*))) ;; hash table.
   
   (incf count)
   (when (zerop (mod count 20))
	 (format t "LFG [~3D]~%" count))

   (unless func-name	;; if the lisp function was not registered
	;; Create a function name.
	;; If gra-file name is "ibm", then function names are like IBMF-34.
     (setq func-name
       (intern (string-upcase
		 (append-str gra-file (symbol-name (gensym "F-"))))))

	;; And register the lisp function (to avoid duplication).
     (setf (gethash lisp-func *functions*) func-name)

  	;; Give graph-name a value like func-name, but with a "G-"
     (setq graph-name (copy-seq (string func-name)))
     (do ((i (- (length graph-name) 1) (- i 1)))
         ((eq (char graph-name i) #\-) (setf (char graph-name (- i 1)) #\G)))
     (setq graph-name (intern graph-name))

        ;; Change lisp-func to replace graph-code by graph-name.
     (cond ((and (= (length lisp-func) 3) 
	         (eq (car (third lisp-func)) 'mapcar))
            (setq graph-code (third lisp-func))
            (rplaca (cddr lisp-func) graph-name))
           ((= (length lisp-func) 3) 
            (setq graph-code (second (third lisp-func)))
            (rplaca (cdr (third lisp-func)) graph-name))
           ((eq (car (fourth lisp-func)) 'mapcar)
            (setq graph-code (fourth lisp-func))
            (rplaca (cdddr lisp-func) graph-name))
    	   (t
            (setq graph-code (second (fourth lisp-func)))
            (rplaca (cdr (fourth lisp-func)) graph-name)))

	;; Push final function/graph definitions to FUN-LIST.
	;;
     (push `(defvar ,graph-name nil) fun-list)
     (push `(setq ,graph-name ,graph-code) fun-list)
     (push `(defun ,func-name ,@(cdr lisp-func)) fun-list)
   )
	
	;; Push rule with function name into ACFG.
	;;
   (push (list lhs rhs func-name) acfg)

;; (format t "~A~%" (symbol-name func-name))
  ))

	;; Return a list of ACFG and FUN-LIST.
 (setq acfg (nreverse acfg))
 (setq fun-list (nreverse fun-list))
 (format t "*** LFG Compiler done~%")
 (list acfg fun-list))
)

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Vsp: 0 -*-

;;;
;;;          PROGRAM STG (Simple Table Generater)
;;;
;;;               by H.Kagamida
;;;

;;;         History
;;;           870210    start
;;;               12 v2 start (from v1 (stg1.lisp;9))
;;;               28 2a start (for tg33)
;;;             0601 3a start on-memory version (at CMU); 'a' for TG-SYSTEM
;;;                           takes *gg* and returns a list of *gg*, *a-tab*, *g-tab*

;; constances
(defparameter %end-of-sentence% '$)
(defparameter %shift-mark%      'S)
(defparameter %reduce-mark%     'R)
(defparameter %accept-mark%     'A)
;; tables
(defvar *grammar*)      ;; grammar      (so-called '*gg*')
(defvar *a-table*) 	;; action table (so-called '*a-tab*')
(defvar *g-table*)   	;; goto   table (so-called '*g-tab*')
;; symbols
(defvar *start-symbol*)
;; fixnums
(defvar *rule-count*)   ;; the # of rules in grammar
(defvar *state-count*)  ;; the # of states
(defvar *rule-counter*) ;; what's this?
(defvar *start-time-stg3a*) ;; time this program started
(defvar *end-time-stg3a*)   ;; time this program finished
;; keywords
(defvar *grammar-stg3a*)
(defvar *message*)
(defvar *timing?-stg3a*)
(defvar *menu?-stg3a*  )

;;;
;;;          MACROS
;;;

(defmacro message (message-level &body body)
  `(when (>= *message* ,message-level)
     ,@body))

;;;
;;;          FUNCTIONS
;;;

;;; do-grammar()
;;;   analize(?) grammar
;;;   abandon all declarations ('declare', '*declare*', '@include')
;;;     input : grammar      (list)     ... must be ACed grammar
;;;     output: grammar      (list)     ... grammar without declarations
;;;             start-symbol (symbol?)  ... the start symbol of the grammar
;;;             rule-count   (fixednum) ... the # of rules in the grammar
(defmacro get-one-rule()
  `(do ((rule (pop grammar)
	      (pop grammar)))
       ((or (not (or (eq  'declare  (car rule)) ;; skip these declarations
		     (eq '*declare* (car rule))
		     (eq '@include  (car rule))))
	    (null grammar))
	rule) ;; this is the return value
)) ;; get-one-rule[]

(defun do-grammar (grammar)
  (message 1
    (format t " - reading grammar~%"))
  (let* ((rule-count     1)
	 (1st-rule       (get-one-rule))
	 (start-symbol   (first 1st-rule))
	 (result-grammar (cons 1st-rule nil))
	 (pointer        result-grammar))
    (do ((rule (get-one-rule)
	       (get-one-rule)))
	((null grammar)
	 ;; epilogue (for the last rule)
	 (when rule
	   (setf (cdr pointer) (cons rule nil))
	   (incf rule-count)))
      (incf rule-count)
      (setf (cdr pointer) (cons rule nil) ;; add new rule at the end of grammar
	    pointer       (cdr pointer)))
    (values result-grammar start-symbol rule-count))) ;; do-gramamr()

(defun register-action-stg3a (state-no symbol action table)
  (declare (special table))
  (let ((state-no-&-actions (assoc state-no table)))
    (if state-no-&-actions
	(let* ((symbols-&-actions (cdr state-no-&-actions))
	       (symbol-&-actions  (assoc symbol symbols-&-actions)))
	  (if symbol-&-actions
	      (pushnew            action  (cdr symbol-&-actions) :test #'equal)
	      (push    `(,symbol ,action) (cdr state-no-&-actions))))
	(push `(,state-no (,symbol ,action)) (cdr (last table)))))) ;; register-action-stg3a()

(defun main-stg3a ()
  (setq *a-table* (list (list 0) 		 ;  '((0) (1 ($ (A))))
			(list 1 '($ (A)))))	 ;  Above didn't work due to
						 ;  system bug.  mt
  (setq	*g-table* (list (list 0 (cons *start-symbol* 1))))
					;  `((0 (,*start-symbol* . 1))))
  (setq	*state-count*  1)
  (setq	*rule-counter* 0)
  (dolist (rule *grammar*)
    (incf *rule-counter*)
    (when (zerop (mod *rule-counter* 20))
	(format t "LR- [~D]~%"  *rule-counter*))
    (let ((rhs      (second rule))
	  (state-no 0))
      (loop
	(unless rhs
	  (register-action-stg3a state-no '* `(,%reduce-mark% . ,*rule-counter*) *a-table*)
	  (return))
	(let* ((next-symbol        (pop rhs))
	       (state-no-&-actions (assoc state-no *a-table*))
	       (symbols-&-actions  (cdr state-no-&-actions))
	       (symbol-&-actions   (assoc next-symbol symbols-&-actions))
	       (actions            (cdr symbol-&-actions))
	       (shift-action       (find %shift-mark% actions :test #'eq :key #'car)))
	  (if shift-action
	      (let ((dest-state-no (cdr shift-action)))
		(setq state-no dest-state-no))
	      (let* ((dest-state-no  (incf *state-count*))
		     (new-action    `(,%shift-mark% . ,dest-state-no)))
		(if symbol-&-actions
		    (push new-action (cdr symbol-&-actions))
		    (let ((new-symbol-&-action `(,next-symbol ,new-action)))
		      (if state-no-&-actions
			  (push              new-symbol-&-action  (cdr state-no-&-actions))
			  (push `(,state-no ,new-symbol-&-action) (cdr (last *a-table*))))))
		(setq state-no dest-state-no)))))))) ;; main-stg3a()

(defun lr-table-compiler-lex (grammar        ;; ACed grammar (~.acfg)
	    &key   (timing?  nil)  ;; flag if time or not
		   (message  1)    ;; message level
		   (menu?    nil)) ;; flag if use menu

  (setq *grammar-stg3a* grammar)
  (setq	*timing?-stg3a* timing?)
  (setq *message* message)
  (setq	*menu?-stg3a*   menu?)

  (message 1
    (format t "*** LR Table Compiler for Lex started~%"))

  (multiple-value-setq (*grammar* *start-symbol* *rule-count*)
    (do-grammar *grammar-stg3a*))

  (when *timing?-stg3a*
    (setq *start-time-stg3a* (get-internal-run-time)))

  (main-stg3a)

  (when *timing?-stg3a*
    (setq *end-time-stg3a* (get-internal-run-time))
    (let* ((time         (- *end-time-stg3a* *start-time-stg3a*))
	   (precise-time (/ time internal-time-units-per-second))
	   (float-time   (coerce precise-time 'float)))
      (format t "~&~% - time = ~D sec" float-time)))

;;  (display-results)

  (message 1
    (format t "*** LR Table Compiler for Lex done~%"))

  (list *grammar* *a-table* *g-table*)) ;; lr-table-compiler-lex()
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Vsp: 0 -*- ;;;

;;;;;
;;;;;          file lr-table-compiler
;;;;;               version 34a (870603wed -)
;;;;;
;;;;;          LR parsing table generation program (SLR method)
;;;;;
;;;;;               by Hideto Kagamida (ITI)
;;;;;

;;; history
;;;   1023      on memory
;;;   0218      small change
;;;   0219 v32  grammar management
;;;               update date
;;;               @include (TM, STG)
;;;     21      read-grammar() wo chuushin ni henkou. ichiou ugoita.
;;;     27 v32a for TG33; removed read-grammar() and convert-grammar()
;;;   0603 v34a for ICMT new system

;;; abb.
;;;   act(ion); ary(= array); aug(ment); cont(ent); dest(ination); dir(ectory); elem(ent); fin(ish); fun(ction); gra(mmar)
;;;   init(ial); mer(ge); no(= number); num(ber); prod(uction); res(ult); sym(bol); tab(le); term(inal); val(ue)
;;;   lhs = left hand side; rhs = right hand side; state = item-no-set

;;; this program lacks
;;;   file common_sense.lisp <- [kagamida.uty]
;;;   pp-table() function    <- [kagamida.jlc.uty]u.lisp

;;;     my wish
(proclaim '(optimize speed))

;;;;;     definition of global constances
(defparameter %eof% :eof) ;; end of file
;;;     linguistic symbols
(defparameter %epsilon%       '*e*) ;; null input    (*e*)
(defparameter %end-symbol%    '$)   ;; end of text input
(defparameter %shift-symbol%  's)   ;; shift
(defparameter %reduce-symbol% 'r)   ;; reduce
(defparameter %accept-symbol% 'a)   ;; accept
;;;     other symbols
(defparameter %new-root%           '*s*)       ;; augmented start symbol (S')
(defparameter %declaration-symbol% '*declare*)
(defparameter %inclusion-symbol%   '@include)
;;;     numbers
(defparameter %grammar-array-size% 3000) ;; the # of rules
(defparameter %item-array-size%    10000) ;; the # of items
(defparameter %state-array-size%   4000) ;; the # of states
;;;     strings
(defparameter %rparen-str%           ")")
(defparameter %tg-version-no-str%    "33")
(defparameter %default-grammar-name% "B:[KAGAMIDA.JLC.GRA]SYN9.GRA")
;;;     characters
(defparameter %less-than-char%    #\<)
(defparameter %greater-than-char% #\>)
(defparameter %equal-char%        #\=)
(defparameter %minus-char%        #\-)

;;;;;     definition of global variables
;;;     hash tables
(defvar *lhs=item-nos*)	        ;;   key: lhs (symbol)
                                ;;   val: list of item # (fixnum)
(defvar *knel=knel-no*)	        ;;   key: item-no-set (list of fixnum)
                                ;;   val: item-no-set # (fixnum)
(defvar *lhs&rhs=rule-no*)      ;; mapping function
                                ;;   key: prod (list) cons of lhs and rhs
                                ;;   val: rule # (fixnum) of *grammar-ary*
(defvar *symbols-tg* nil)	;; all grammar symbols used in the grammar
                                ;;   key: grammar symbol used in the grammar (symbol)
                                ;;   val: t
(defvar *terminal-symbols-tg*)     ;; all terminal symbols used in the grammar
(defvar *non-terminal-symbols-tg*) ;; all non terminal symbols used in the grammar
(defvar *first*)	        ;; table for xfirst() function
                                ;;   key: grammar symbol (symbol)
                                ;;   val: list of first symbols (list of symbols)
(defvar *follow*)	        ;; table for follow() function
                                ;;   key: grammar symbol (symbol)
                                ;;   val: list of follow symbols (list of symbols)
(defvar *g-tab0*)	        ;; hash table for *g-tab*
(defvar *symbol-bag-1*)	        ;; symbol bag for item-set-closure()
(defvar *symbol-bag-2*)	        ;; symbol bag for items()
(defvar *symbol-bag-4*)	        ;; symbol bag
(defvar *symbol-bag-5*)	        ;; symbol bag
(defvar *symbol-closure*)       ;;
;;;     arrays
(defvar *grammar-ary*) ;; grammar (<list of rule #s> <lhs and rhs>)
                       ;;   <list of rule #s> : rule # in *gg*
                       ;;   <lhs and rhs>     : 
(defvar *item-ary*)    ;; all items
                       ;;   index = item #
                       ;;   content = (<rule #> <next symbol> <dot position>)
                       ;;               <rule #>       : serial # in *grammar-ary*
                       ;;               <next symbol>  : the symbol following dot
                       ;;               <dot position> : the position of dot
(defvar *state-ary*)   ;; C ... canonical collection of sets of LR( 0 ) items
                       ;;   index = state #
                       ;;   content = list of item #s
;;;     a-lists
(defvar *a-tab*) ;; action table; compatible to parser
(defvar *g-tab*) ;; goto   table; compatible to parser
;;;     lists
(defvar *gg*)		            ;; the original grammar; compatible to parser
(defvar *terminal-symbol-list*)     ;; (pre-)terminal symbols used in the grammar
(defvar *non-terminal-symbol-list*) ;; non-terminal symbols used in the grammar
(defvar *grammar0*)
(defvar *grammar1*)
(defvar *declaration-list*)
(defvar *inclusion-list*)
;;;     fixnums
(defvar *rule-count*)	  ;; the # of rules in grammar (*gg*)
(defvar *new-rule-count*) ;; the # of rules in *grammar-ary*
(defvar *item-count*)	  ;; the # of items
(defvar *state-count*)	  ;; the # of states
(defvar *start-time*)	  ;; internal run time
(defvar *end-time*)	  ;; internal run time
;;;     symbols
(defvar *root*)	     ;; starting symbol of grammar
;;;     flags
(defvar *arrow-used?*)
;;;     keywords
(defvar *lookahead*)
(defvar *grammar-tg*)
(defvar *timing?-tg*)
(defvar *message*)
(defvar *on-memory-tg*)
;;;     others
(defvar *input-grammar*)
(defvar *the-grammar-name*)
(defvar *the-directory-name*)

;;;          macros

(defmacro message (message-level &body body)
  `(when (>= *message* ,message-level)
     ,@body))

;;;;;     definition of general functions

;;;;;     access functions
(defmacro rule-no->rule (rule-no)
  "`(svref *grammar-ary* ,rule-no))"
  `(svref *grammar-ary* ,rule-no))

(defmacro rule->rule-nos (rule)
  "`(car ,rule))"
  `(car ,rule))

(defmacro rule->lhs (rule)
  "`(second ,rule))"
  `(second ,rule))

(defmacro rule->rhs (rule)
  "`(cddr ,rule))"
  `(cddr ,rule))

(defmacro item-no->item (item-no)
  "`(svref *item-ary* ,item-no))"
  `(svref *item-ary* ,item-no))

(defmacro item->rule-no (item)
  "`(car ,item))"
  `(car ,item))

(defmacro item->next-sym (item)
  "`(second ,item))"
  `(second ,item))

(defmacro lhs->item-nos (lhs)
  "`(gethash ,lhs *lhs=item-nos*))"
  `(gethash ,lhs *lhs=item-nos*))

(defmacro lhs&rhs->rule-no (lhs&rhs)
  "`(gethash ,lhs&rhs *lhs&rhs=rule-no*))"
  `(gethash ,lhs&rhs *lhs&rhs=rule-no*))

(defmacro knel->knel-no (knel)
  "`(gethash ,knel *knel=knel-no*))"
  `(gethash ,knel *knel=knel-no*))

(defmacro state-no->state (state-no)
  "`(svref *state-ary* ,state-no))"
  `(svref *state-ary* ,state-no))

(defun prologue-tg ()
  (setq *symbol-bag-1*         (make-hash-table :test #'eql)
	*grammar-ary*          (make-array %grammar-array-size%) ;; read grammar
	*symbols-tg*              (make-hash-table :test #'eql)
	*terminal-symbols-tg*     (make-hash-table :test #'eql)
	*non-terminal-symbols-tg* (make-hash-table :test #'eql)
	*lhs&rhs=rule-no*      (make-hash-table :test #'equal)
	*first*                (make-hash-table :test #'eql)     ;; make first table
	*follow*               (make-hash-table :test #'eql)     ;; make follow table
	*item-ary*             (make-array %item-array-size%)    ;; make all items
	*lhs=item-nos*         (make-hash-table :test #'eql)
	*g-tab0*               (make-hash-table :test #'eql)     ;; collection of items
	*knel=knel-no*         (make-hash-table :test #'equal)
        *symbol-closure*       (make-hash-table :test #'eq )
	*symbol-bag-2*         (make-hash-table :test #'eql)
	*symbol-bag-4*         (make-hash-table :test #'eql)
	*symbol-bag-5*         (make-hash-table :test #'eql)
	*state-ary*            (make-array %state-array-size%)
	*a-tab*                 nil                      ;; main routine
	*g-tab*                 nil))

(defmacro symbol-p (sym)
  `(gethash ,sym *symbols-tg*))

(defmacro terminal-symbol-p-tg (sym)
  `(gethash ,sym *terminal-symbols-tg*))

(defmacro non-terminal-symbol-p-tg (sym)
  `(gethash ,sym *non-terminal-symbols-tg*))

(defun parse-declare (declaration)
  (let ((declare (pop declaration))) declare ;; omit '*declare*'
    (dolist (sub-dec declaration)
      (let ((dec-name (pop sub-dec))) ;; declaration name
	(case dec-name
	  (*non-terminal-symbols-tg* (dolist (non-term-sym sub-dec)
				    (setf (non-terminal-symbol-p-tg non-term-sym) t))))))))

(defun register-symbols (prod)
  (let ((lhs (car prod)))
    (setf (non-terminal-symbol-p-tg lhs) t) ;; to *non-terminal-symbols-tg*
    (dolist (sym prod)
      (setf (symbol-p sym) t))))         ;; to              *symbols-tg*

(defun convert-grammar-tg ()
  (message 1
    (format t " - converting grammar~%"))
  (setq *input-grammar*	*grammar-tg*)
  (clrhash *symbols-tg*)
  (clrhash *non-terminal-symbols-tg*)
  (setq *gg*             nil
        *rule-count*     0
	*new-rule-count* 0)
  (let ((*readtable* (copy-readtable nil)))
    (set-syntax-from-char #\: #\a)                                        ;; to accept time spec
    (set-syntax-from-char #\' #\a)                                        ;; to accept apostrophy
    (let* ((1st-rule (first *input-grammar*))
	   (1st-elem (car 1st-rule)))
      (when (eq 1st-elem %declaration-symbol%)
	(parse-declare 1st-rule)
	(pop *input-grammar*))
      (dolist (rule *input-grammar*)
	(incf *rule-count*)                                               ;; increment rule number counter
	(let* ((lhs     (pop rule))                                       ;; left hand side
	       (rhs     (car rule))                                       ;; right hand side
	       (lhs&rhs (cons lhs rhs))
	       (rule-no (lhs&rhs->rule-no lhs&rhs))) ;; to avoid warning
	      (unless rhs                                                     ;; if rhs is null
		(error "~& [CONVERT-GRAMMAR-TG34A] - I found null right hand side"))
	      (push (cons lhs rule) *gg*)                                     ;; register production to construct a *gg* for the parser
	      (if rule-no                                                     ;; if there is already a rule which has same lhs and rhs
		(push *rule-count* (car (rule-no->rule rule-no)))           ;; 10/23 mida combined
		(progn
		  (register-symbols lhs&rhs)                                ;; registration of symbols
		  (setf (lhs&rhs->rule-no lhs&rhs) (incf *new-rule-count*)) ;; registration to *lhs&rhs=rule-no*
		  (setf (rule-no->rule *new-rule-count*)                    ;; registration to *grammar-ary*
			(cons (list *rule-count*) lhs&rhs))))))))
  (setq *gg*   (nreverse *gg*)
	*root* (caar     *gg*))
  (clrhash *terminal-symbols-tg*)
  (setq *terminal-symbol-list*     nil
	*non-terminal-symbol-list* nil)
;  (flet ((sieve-symbols (key val) val
;			(if (non-terminal-symbol-p-tg key)
;			  (push key *non-terminal-symbol-list*)
;			  (progn
;			    (setf (terminal-symbol-p-tg key) t)
;			    (push key *terminal-symbol-list*)))))
;    (maphash #'sieve-symbols *symbols-tg*))
  (sieve-symbols)
  (flet ((to-string (item)
	   (typecase item
	     (symbol (symbol-name item))
	     (fixnum (string (int-char (+ item (char-int #\0))))))))
    (flet ((symbol< (sym1 sym2)
	     (let ((sym-nam1 (to-string sym1))
		   (sym-nam2 (to-string sym2)))
	       (string< sym-nam1 sym-nam2))))
      (setq *terminal-symbol-list*     (sort *terminal-symbol-list*     #'symbol<))
      (setq *non-terminal-symbol-list* (sort *non-terminal-symbol-list* #'symbol<))))) ;; convert-grammar-tg()

;;; arrow-p()
;;;   this function check whether symbol is an arrow or not.
;;;   if the symbol consists of characters <, >, -, =,
;;;   the function regards the symbol as an arrow.
(defun arrow-p (symbol)
  (let* ((sym-str     (symbol-name symbol))
	 (sym-str-len (length sym-str)))
    (dotimes (i sym-str-len t)
      (let ((char (char sym-str i)))
	(unless (member char `(,%less-than-char%    ;; <
			       ,%greater-than-char% ;; >
			       ,%equal-char%        ;; =
			       ,%minus-char%)       ;; -
			:test #'eq)
	  (return-from arrow-p nil))))))

;;; sieve-symbols()
;;;   determine whether a symbol terminal or non-terminal
;;;   [algorithm]
;;;     for all symbols which appeared in the grammar:
;;;       if a symbol appeared in LHS more than once
;;;         then {the symbol is non-terminal}
;;;           push that symbol to *non-terminal-symbol-list* variable (list)
;;;         else
;;;           if the symbol has '<' in the begining of it's name ... *
;;;             then {the symbol is non-terminal}
;;;               register that symbol to hash-table
;;;               push that symbol to *non-terminal-symbol-list* var. (list)
;;;             else {the symbol is terminal}
;;;               push that symbol to *terminal-symbol-list* var. (list)
;;;   870520 mida(cmu) added new condition(*); removed flet().
(defun sieve-symbols ()
  (maphash
    #'(lambda (key val)
	val ;; to avoid warning
	(if (non-terminal-symbol-p-tg key)
	    (push key *non-terminal-symbol-list*)
	    (progn
	      (if (and (not (numberp key))
		       (char= (char (symbol-name key) 0) #\<))
		(let ()
		  (setf (non-terminal-symbol-p-tg key) t)
		  (push key *non-terminal-symbol-list*))
		(let ()
	          (setf (terminal-symbol-p-tg key) t)
	          (push key *terminal-symbol-list*))))))
    *symbols-tg*)) ;; sieve-symbols()

;;; change-to-string( item )
;;;   change item (symbol or fixnum) to string
(defun change-to-string (item)
  (typecase item
	     (symbol (symbol-name item))
	     (fixnum (string (int-char (+ item (char-int #\0)))))))

;;; symbol<( symbol-1 symbol-2 )
;;;   order function for symbols
(defun symbol< (symbol-1 symbol-2)
  (let ((symbol-name-1 (change-to-string symbol-1))
	(symbol-name-2 (change-to-string symbol-2)))
    (string< symbol-name-1 symbol-name-2)))

;;; sort-symbol-lists()
;;;   sort symbol lists (*terminal-symbol-list* and *non-terminal-symbol-list*)
(defmacro sort-symbol-lists ()
  `(progn
     (setq *terminal-symbol-list*     (sort *terminal-symbol-list*     #'symbol<))
     (setq *non-terminal-symbol-list* (sort *non-terminal-symbol-list* #'symbol<)))) ;; sort-symbol-lists()

;;; Hash-table-size() ... measure the size of hash table '*first*'
;;;   the contents of hash table is a list
;;;   this function counts the number of all elements in all list in the hash
;;;   table
(defun cl-hash-table-size (h-tab)
  (let ((count 0))
    (flet ((count-up (key val)
	     (declare (ignore key)) key ;; to avoid warning
	     (let ((list-len (length val)))
	       (incf count list-len))))
      (maphash #'count-up h-tab))
    count)) ;; cl-hash-table-size()

;;;     xfirst ... FIRST( X ) function (DRAGON BOOK p187-)
;;;                X : all grammar symbols
(defmacro xfirst (sym)
  `(gethash ,sym *first*))

;;; make-first-table()
;;;   Sep 23rd, 1986
;;;   see page 167 of ref. book #2
;;;   caution: this routine is not thinking of a null right hand side (epsilon)
(defmacro make-first-table-macro ()
  `(dolist (pair link-root)
     (let* ((lhs          (car pair))
	    (first-symbol (cdr pair))
	    (first-set    (xfirst first-symbol)))
       (dolist (sym first-set)
	 (pushnew sym (xfirst lhs)))))) ;; make-first-table-macro()

(defun make-first-table ()
  (setq *first* (make-hash-table :test #'eql))
  (let* ((old-cell  (cons nil nil))
	 (link-root old-cell) ;; the root of linear list
	 (old-count nil)
	 (new-count nil))
    ;; step 1
    (dolist (term-sym *terminal-symbol-list*)
      (push term-sym (xfirst term-sym)))
    (dotimes (index *new-rule-count*)
      (let* ((rule-no      (+ index 1))
	     (rule         (rule-no->rule rule-no))
	     (lhs          (rule->lhs rule))
	     (rhs          (rule->rhs rule))
	     (first-symbol (car rhs)))
	(if (terminal-symbol-p-tg first-symbol)
	    ;; step 2
	    (pushnew first-symbol (xfirst lhs))
	    ;; preparation for step 3
	    ;; reserve a pair (lhs and first symbol of rhs) in a linear list
	    (let* ((new-pair (cons lhs first-symbol))
		   (new-cell (cons new-pair nil)))
	      (setf (cdr old-cell) new-cell)
	      (setq old-cell new-cell))))) ;; proceed the pointer
    (pop link-root)
    (make-first-table-macro)
    (setq old-count (cl-hash-table-size *first*))
    (tagbody
      loop-top
      (make-first-table-macro)
      (setq new-count (cl-hash-table-size *first*))
      (when (= old-count new-count)
	(return-from make-first-table (values)))
      (setq old-count new-count)
      (go loop-top)))) ;; make-first-table()

;;;;;     follow ... FOLLOW(A) function (algorithm DRAGON BOOK p189)
;;;;;                A : non terminal symbol
(defmacro follow (sym)
  `(gethash ,sym *follow*))

;;; make-follow-table()
;;; 861001 - 1002
;;; book #2 p167
;;; note: this routine doesn't deal with epsilon
(defun make-follow-table (&aux old-count new-count)
  (setq *follow* (make-hash-table :test #'eql))
  ;; step 1.
  (push %end-symbol% (gethash *root* *follow*))
  ;; step 2.
  (dotimes (index *new-rule-count*)
    (let* ((rule-no (+ index 1))
	   (rule    (rule-no->rule rule-no))
	   (rhs     (rule->rhs rule))
	   (sym1    (pop rhs))
	   (sym2    (pop rhs)))
      (do ()
	  ((null sym2))
	(when (non-terminal-symbol-p-tg sym1)
	  (dolist (sym (xfirst sym2))
	    (pushnew sym (gethash sym1 *follow*))))
	(shiftf sym1 sym2 (pop rhs)))))
  ;; step 3.
  (setq old-count (cl-hash-table-size *follow*))
  (loop
    (dotimes (index *new-rule-count*)
      (let* ((rule-no     (+ index 1))
	     (rule        (rule-no->rule rule-no))
	     (lhs         (rule->lhs rule))
	     (rhs         (rule->rhs rule))
	     (las-sym-lis (last rhs)); last symbol list
	     (las-sym     (car las-sym-lis))) ;; last symbol
	(when (non-terminal-symbol-p-tg las-sym)
	  (dolist (sym (follow lhs))
	    (pushnew sym (gethash las-sym *follow*))))))
    (setq new-count (cl-hash-table-size *follow*))
    (when (= old-count new-count)
      (return-from make-follow-table (values)))
    (setq old-count new-count))) ;; make-follow-table

;;;;;     make-augmented-grammar() ... make augmented grammar G' ; DRAGON BOOK p205
(defun make-augmented-grammar ()
  (let ((augmented-rule (list '(0) %new-root% *root*)))
    (setf (rule-no->rule 0) augmented-rule)))

;;;;;
;;;;;     making all items
;;;;;
(defun register-item (rule-no next-sym dot-pos)
  (let ((new-item (list rule-no next-sym dot-pos)))
    (setf (item-no->item (incf *item-count*)) new-item)))

;;;;;     make-all-items ()
(defun make-all-items ()
  (setq *item-count* 0)
  (register-item 0 *root* 0) ;; rule # is 0, next symbol is *root*, dot position is 0
  (register-item 0 nil    1)      ;; rule # is 0, next symbol is nil,    dot position is 1
  (dotimes (i *new-rule-count*)	;; i moves from 0 to (*new-rule-count* - 1)
    (let* ((rule-no  (1+ i)) ;; moves from 1 to *new-rule-count*
	   (rule     (rule-no->rule rule-no))
	   (lhs      (rule->lhs rule))
	   (rhs      (rule->rhs rule))
	   (rhs-len  (length rhs))
	   (next-sym (pop    rhs)))
      (register-item rule-no next-sym 0) ;; register this item
      (push *item-count* (lhs->item-nos lhs)) ;; register to hash table
      (dotimes (i rhs-len) ;; i moves from 0 to (rhs-len - 1)
	(let ((dot-pos  (+ i 1)) ;; dot-pos moves from 1 to rhs-len
	      (next-sym (pop rhs))) ;; next right hand side element
	  (register-item rule-no next-sym dot-pos))))) ;; register new item
  (flet ((set-reverse (key value)
	   (setf (lhs->item-nos key) (nreverse value))))
    (maphash #'set-reverse *lhs=item-nos*))) ;; make-all-items

;;;;;     item-set-closure ... CLOSURE( I ) ; DRAGON BOOK p205 
;;;;;                               ; I ... set of items
(defmacro registered-symbol-p (sym *symbol-bag*)
  `(gethash ,sym ,*symbol-bag*))

(defmacro register-symbol (sym *symbol-bag*)
  `(setf (gethash ,sym ,*symbol-bag*) t))

(defmacro symbol->closure (sym)
  `(gethash ,sym *symbol-closure*))

(defun symbol-closure (sym)
  (let ((res-closure (symbol->closure sym))) ;; consult the record
    (unless res-closure
      (if (registered-symbol-p sym *symbol-bag-4*) ;; if infinite loop
	  (progn
	    (clrhash *symbol-bag-5*)
	    (setq res-closure (lhs->item-nos sym))
	    (let ((item-nos-count (length res-closure)))
	      (do ((i 1 (+ i 1)))
		  ((> i item-nos-count))
		(let* ((item-no  (nth (- item-nos-count i) res-closure))
		       (item     (item-no->item item-no))
		       (next-sym (item->next-sym item)))
		  (when (and (non-terminal-symbol-p-tg next-sym)
			     (not (registered-symbol-p next-sym *symbol-bag-5*)))
		    (register-symbol next-sym *symbol-bag-5*)
		    (let ((item-nos (lhs->item-nos next-sym)))
		      (dolist (item-no item-nos)
			(unless (member item-no res-closure :test #'eql)
			  (incf item-nos-count)
			  (push item-no res-closure)))))))))
	  (progn ;; else (not infinite loop)
	    (register-symbol sym *symbol-bag-4*) ;; set infinite loop flag
	    (let ((item-nos     (lhs->item-nos sym))
		  (*symbol-bag* (make-hash-table :test #'eq)))
	      (setq res-closure item-nos)
	      (dolist (item-no item-nos)
		(let* ((item     (item-no->item item-no))
		       (next-sym (item->next-sym item)))
		  (unless (registered-symbol-p next-sym *symbol-bag*)
		    (register-symbol next-sym *symbol-bag*)
		    (setq res-closure (union res-closure (symbol-closure next-sym)))))))))
      (setf (symbol->closure sym) res-closure)) ;; learn the result
    res-closure)) ;; symbol-closure()

(defun item-set-closure (kernel)
  (let ((res-state kernel))
    (clrhash *symbol-bag-1*)
    (clrhash *symbol-bag-4*) ;; to avoid the infinite loop of calling item-set-closure()
    (dolist (item-no kernel)
      (let* ((item     (item-no->item item-no))
	     (next-sym (item->next-sym item)))
	(when (and (non-terminal-symbol-p-tg next-sym)
		   (not (registered-symbol-p next-sym *symbol-bag-1*)))
	  (register-symbol next-sym *symbol-bag-1*)
	  (setq res-state (union res-state (symbol-closure next-sym))))))
    res-state)) ;; item-set-closure()

;;;;;     goto ... GOTO( I, X ) ; DRAGON BOOK p207
;;;;;                           ; I ... set of items
;;;;;                           ; X ... grammar symbol
(defun add-item-no (item-no state)
  (if (null state)
      (list item-no)
      (let ((1st-item-no (car state)))
	(if (< item-no 1st-item-no)
	    (cons item-no state)
	    (if (> item-no 1st-item-no)
		(cons 1st-item-no (add-item-no item-no (cdr state)))
		state))))) ;; add-item-no

;;;;;     proc-dot() ... proceed dot (for example E -> . E  =>  E -> E .)
(defun proc-dot (item-no)
  (let* ((item     (item-no->item item-no))
         (next-sym (item->next-sym item)))
    (if next-sym
        (+ 1 item-no)
	item-no))) ;; proc-dot()

(defun goto-only (state sym)
  (declare (inline proc-dot))
  (let ((dest-knel nil))
    (dolist (item-no state)
      (let* ((item     (item-no->item item-no))
	     (next-sym (item->next-sym item)))
	(when (eql next-sym sym)
	  (let ((new-item-no (proc-dot item-no)))
	    (setq dest-knel (add-item-no new-item-no dest-knel))))))
    dest-knel)) ;; goto-only()

(defmacro goto1 (state-no sym)
  `(cdr (assoc ,sym (gethash ,state-no *g-tab0*) :test #'eql)))

;;;;;     items ... ITEMS( G' ) ; DRAGON BOOK p207
;;;;;                           ; G' ... augmented grammar
(defun items ()
  (setf (state-no->state 0) (item-set-closure '(1)))
  (setq	*state-count* 1)
  (do ((state-no    0 (+ 1 state-no))
       (state-count 1      (+ 1 state-count)))
      ((> state-count *state-count*))
    (when (or (< state-no 20)(zerop (mod state-no 20)))
      (format t "LR [~3D]~%" state-no))
    (let ((state (state-no->state state-no)))
      (clrhash *symbol-bag-2*)
      (dolist (item-no state)
        (let* ((item     (item-no->item item-no))
	       (next-sym (item->next-sym item)))
	  (when (and next-sym			; dot is not the last symbol
		     (not (registered-symbol-p next-sym *symbol-bag-2*))) ;; not registered
	    (register-symbol next-sym *symbol-bag-2*) ;; register the symbol
	    (let ((dest-knel (goto-only state next-sym)))
	      (when dest-knel
		(let* ((dest-knel-no  (knel->knel-no dest-knel))
		       (dest-state-no  dest-knel-no))
		  (unless dest-knel-no
		    (let ((dest-state (item-set-closure dest-knel)))
		      (shiftf dest-state-no *state-count* (+ 1 *state-count*))
		      (setq dest-knel-no dest-state-no)
		      (setf (state-no->state dest-state-no) dest-state)
		      (setf (knel->knel-no dest-knel) dest-knel-no)))
		  (let ((cont (cons next-sym dest-state-no)))
		    (push cont (gethash state-no *g-tab0*)))))))))))) ;; items()

(defun add-action-table (sym new-action action-list)
  (let ((cont (assoc sym action-list :test #'eql)))
    (if cont
	(unless (member new-action cont :test #'equal)
	  (let* ((new-cont        `(,@cont ,new-action)) ;; (add-last new-action cont))
		 (new-action-list (substitute new-cont cont action-list :test #'equal)))
	    (setq action-list new-action-list)))
	(let ((new-cont (list sym new-action)))
	  (push new-cont action-list))))
  action-list) ;; returns new action-list

;;;;;     generate-table ... construction of an SLR parsing table (DRAGON BOOK p211 Algorithm 6.1)
(defun generate-table ()
  (setq *a-tab* nil)
  (let ((item-no-for-accept  2) ;; for step 3
	(act-for-accept     (list %end-symbol% (list %accept-symbol%)))) ;; for step 3
    (dotimes (state-no *state-count*)
      (when (zerop (mod state-no 20))
	(format t "LR'[~3D]~%" state-no))
      (let ((item-no-set (state-no->state state-no))
	    (act-list     nil)) ;; action list of this state
	(dolist (item-no item-no-set)
	  (let* ((item      (item-no->item item-no))
		 (rule-no   (item->rule-no item))
		 (rule      (rule-no->rule rule-no))
		 (next-sym0 (item->next-sym item)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		 (next-sym  nil))            ;;; to avoid of let() binding bug of common lisp (0411 Fuji, Mida) ;;;
	    (setq next-sym next-sym0)              ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	    (when (or (terminal-symbol-p-tg next-sym) ;; ##### step 1 (shift) #####
		      (eq next-sym %epsilon%))
	      (let* ((dest-item-no-set-no (goto1 state-no next-sym))
		     (new-act             (cons %shift-symbol% dest-item-no-set-no))
		     (new-act-list        (add-action-table next-sym new-act act-list)))
		(setq act-list new-act-list)))
	    (unless next-sym ;; ##### step 2 (reduce) #####
	     (if (zerop *lookahead*)

		;; if *lookahead* = 0
		;;
	      (let ((lhs         (rule->lhs rule))
		    (rule-nos (rule->rule-nos rule)))
		     (dolist (rule-no rule-nos)
		      (declare (fixnum rule-no))
		      (unless (zerop rule-no)	
		       (let* ((new-act      (cons %reduce-symbol% rule-no))
			      (new-act-list (add-action-table '* new-act act-list)))
			(setq act-list new-act-list)))))

		;; if *lookahead* = 1
		;;
	      (let* ((lhs         (rule->lhs rule))
		     (follow-syms (follow lhs)))
		(dolist (term-sym follow-syms)
		  (let ((rule-nos (rule->rule-nos rule))) ;; rule #s
		    (dolist (rule-no rule-nos)
		      (let* ((new-act      (cons %reduce-symbol% rule-no))
			     (new-act-list (add-action-table term-sym new-act act-list)))
			(setq act-list new-act-list))))))
	      ))))  
	(when (member item-no-for-accept item-no-set :test #'eql) ;; ##### step 3 (accept) #####
	  (push act-for-accept act-list))
	(if (null act-list) (setq act-list '(($))))
	(let* ((new-act-list (reverse act-list))
	       (new-cont     (cons state-no new-act-list)))
	    (push new-cont *a-tab*)))))
  (setq *a-tab* (nreverse *a-tab*))) ;; generate-table()

;;;;;     reform-goto-table ... construct goto table from hash table
(defun reform-goto-table ()
  (setq *g-tab* nil)
  (do ((state-no (1- *state-count*) (1- state-no)))
      ((< state-no 0))
    (flet ((remove-condition (content)
	     (let ((key-sym     (first content))
		   (dest-states (rest  content)))
	       (or (terminal-symbol-p-tg key-sym) ;; goto table doesn't need terminal symbol as a key
		   (null      dest-states))))) ;; this content represents goes nowhere
      (let* ((old-cont (gethash state-no *g-tab0*))
	     (new-cont (remove-if #'remove-condition old-cont)))
	(when new-cont
	  (push (cons state-no new-cont) *g-tab*)))))) ;; reform-goto-table()

(defun pp-gg (tab &optional (output t))
  (format output "~&(")
  (dolist (rule tab)
    (format output "~&  ~S" rule))
  (format output %rparen-str%))

;;;;;          TOP FUNCTION
;;;;;

;;;;;     LR-TABLE-COMPILER (SLR parsing table generation execution)
;;;;;
(defun lr-table-compiler (grammar ;; grammar
	      &key (lookahead 0)  ;; by mt
		   (timing? nil)
		   (message 1))  ;; message flag
  
"lr-table-compiler()
     grammar                             (list)
   keyword arguments
     :timing? flag if time               (t or nil; default = nil)
     :message parameter of message level (0 - 2; default = 1)"
  
;;;     start timing
  (when timing?
    (setq *start-time* (get-internal-real-time)))
  
  (setq *grammar-tg* grammar
	*timing?-tg* timing?
	*lookahead* lookahead
	*message* message)

  (message 1
    (format t "*** LR Table Compiler started~%"))

  (prologue-tg)
;;;
  (setq *on-memory-tg* 2) ;; grammar is ACed     (*grammar1*)
  
;;;     read grammar

  (if *on-memory-tg*
      (convert-grammar-tg))
  (message 1
    (format t " - there were ~D                  rules~%"  *rule-count*)
    (format t " - there were ~D really different rules~%"  *new-rule-count*)
    (format t " - there were ~D symbols~%"                (hash-table-count *symbols-tg*))
    (format t " - there were ~D terminal symbols~%"       (hash-table-count *terminal-symbols-tg*))
    (format t " - there were ~D non terminal symbols~%"   (hash-table-count *non-terminal-symbols-tg*)))
  (message 2
    (format t "~& - terminal symbols are~%")
    (dolist (sym *terminal-symbol-list*)
      (format t " ~S" sym))
    (format t "~& - non terminal symbols are~%")
    (dolist (sym *non-terminal-symbol-list*)
      (format t " ~S" sym)))

;;;     make first table
  (when (= lookahead 1)
   (message 1
     (format t " - making first table~%"))
   (make-first-table))

;;;     make follow table
  (when (= lookahead 1)
   (message 1
     (format t " - making follow table~%"))
   (make-follow-table))
  
;;;     make augmented grammar
  (message 1
    (format t " - making augmented grammar~%"))
  (make-augmented-grammar)
  
;;;     make all items
  (message 1
    (format t " - making all items~%"))
  (make-all-items)
  (message 1
    (format t " - ~D items made~%" *item-count*))
  
;;;     collection of items
  (message 1
    (format t " - collecting all items~%"))
  (items)
  (message 1
    (format t " - the number of states is ~A~%" *state-count*))
  
;;;     main routine
  (message 1
    (format t " - generating parsing table~%"))
  (generate-table)
  
;;;     reform table
  (message 1
    (format t " - reforming goto table~%"))
  (reform-goto-table)

;;;     timing
  (when *timing?-tg*
    (setq *end-time* (get-internal-real-time))
    (message 2
      (format t "~&~% - start time = ~D msec~%" *start-time*)
      (format t     " -   end time = ~D msec~%" *end-time*)
      (format t     " -       time = ~D msec"  (- *end-time* *start-time*))))

  (message 1
    (format t "*** LR Table Compiler done~%"))

  (list *gg* *a-tab* *g-tab*)) ;; lr-table-compiler()


;;; ===============================================================
;;;							
;;;	    Code for Pseudo Unification Grammar Formalism
;;; 	    ---------------------------------------------
;;;                	  Masaru Tomita		
;;; 		  Center for Machine Translation
;;; 		   Carnegie-Mellon University
;;;			  February 1988
;;; 			   Version 3-2
;;;				
;;; ================================================================

;;; ----------------------------------------------------------------
;;;
;;; 	The following file is required:
;;; 		util.lisp for MAP-DOLIST, APPEND-DOLIST, OR-DOLIST
;;; 
;;;   HISTORY
;;; 
;;; 27-Jan-88 	Masaru Tomita (mt) at Carnegie-Mellon University
;;;	Created from v7.6, removing all semantic stuff.
;;; 23-Feb-88   Masaru Tomita (mt) at Carnegie-Mellon University
;;;     Merge all compilation functions.
;;; ________________________________________________________________
;;; 

;;; ________________________________________________________________
;;;
;;;   Global Variable declarations and initializations
;;; ________________________________________________________________
;;; 

;;; 
;;; *FS-LIST* - a list of all possible f-structures built so far.
;;; 
(defvar *fs-list*) 


;;; ________________________________________________________________
;;; 
;;;    Miscellaneous Functions
;;; ________________________________________________________________

;;; 
;;; CONSTIT-LIST - used in the following function, RESISTERP.
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;; 
;;;  RESISTERP returns t if x is one of x0, x1, x2, x3,...
;;; 
(defun resisterp (x)
  (member x CONSTIT-LIST))

;;; 
;;;  PATHP returns t if x is a path.
;;; 
(defun pathp (x)
  (and (listp x) (resisterp (car x))))

(defmacro map-dolist+ (varlist body)
 `(remove '*FAIL* (map-dolist ,varlist ,body)))

;;; _____________________________________________________________
;;; 
;;;   Type Conversion Functions
;;; _____________________________________________________________
;;; 

;;; 
;;; LIST-TO-VALUE converts a list of values into a value.
;;; (a b c) ==> (*OR* a b c)
;;; (a)     ==>  a
;;;
(defun list-to-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*OR* v-list))))

;;; 
;;; VALUE-TO-LIST is inverse LIST-TO-VALUE
;;; (*OR* a b c) ==> (a b c)
;;;  a  ==>  (a)
;;;
(defun value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*OR*)(cdr v))
        (t (list v))))

;;; 
;;; LIST-TO-MULTI-VALUE converts a list of values into a multi-value.
;;; (a b c) ==> (*MULTIPLE* a b c)
;;; (a)     ==>  a
;;;
(defun list-to-multi-value (v-list)
  (cond ((null v-list) nil)
	((eq (length v-list) 1)(car v-list))
	(t (cons '*MULTIPLE* v-list))))

;;; 
;;; MULTI-VALUE-TO-LIST is inverse LIST-TO-MULTI-VALUE
;;; (*MULTIPLE* a b c) ==> (a b c)
;;;  a  ==>  (a)
;;;
(defun multi-value-to-list (v)
  (cond ((null v) nil)
	((atom v)(list v))
	((eq (car v) '*MULTIPLE*)(cdr v))
        (t (list v))))

;;; 
;;; POP-MULTI-VALUE removes the first element of a multi-value.
;;; (pop-multi-value '(*MULTIPLE* a b c)) --> (*MULTIPLE* b c)
;;; 
(defun pop-multi-value (v)
  (setq v (multi-value-to-list v))
  (if (null v) '*FAIL*
      (list-to-multi-value (cdr v))))

;;; 
;;;  VAL type indentifier
;;;
;;;   NULL	nil
;;;   ATOM	atom value
;;;   OR        (*OR* ......)
;;;   NOT       (*NOT* .....)
;;;   MULTI     (*MULTIPLE* ...)
;;;   FS        f-structure
;;;   USER	User-defined special type
;;;
(defun fs-type (fs)
  (cond ((null fs) 'NULL)
        ((atom fs) 'ATOM)
	((eq (car fs) '*OR*) 'OR)
	((eq (car fs) '*NOT*) 'NOT)
        ((eq (car fs) '*MULTIPLE*) 'MULTI)
	((atom (car fs)) 'USER)
        (t 'FS)))

;;; 
;;; Macros for checking types.
;;; 
(defmacro or-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*OR*)))
(defmacro multi-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*MULTIPLE*)))
(defmacro not-p (fs)
  `(and (not (atom ,fs))(eq (car ,fs) '*NOT*)))
(defmacro user-p (fs)
  `(and (not (atom ,fs))(atom (car ,fs))))

;;; _____________________________________________________________
;;; 
;;;   Error handling functions
;;; _____________________________________________________________
;;; 

;;; 
;;;  EQUATION-ERROR
;;; 
(defun equation-error (object)
  (format t "~%### INVALID EQUATION ~S~%" object)
  nil)


;;; _____________________________________________________________
;;; 
;;;  Handling of PSEUDO equations
;;; _____________________________________________________________
;;; 

;;; 
;;;  Top level macros
;;; 
(defmacro p=p (path1 path2)
  `(setq x (path=path x ',path1 ',path2)))
(defmacro p=a (path atom)
  `(setq x (path=atom x ',path ',atom)))
(defmacro p=d (path)
  `(setq x (path=defined x ',path)))
(defmacro p=u (path)
  `(setq x (path=undefined x ',path)))
(defmacro p=r (path)
  `(setq x (path=remove x ',path)))
(defmacro p=ca (path atom)
  `(setq x (path=catom x ',path ',atom)))
(defmacro p>p (path1 path2)
  `(setq x (path>path x ',path1 ',path2)))
(defmacro p>a (path atom)
  `(setq x (path>atom x ',path ',atom)))
(defmacro p=l (path lispcode)
  `(setq x (path=lispcode x ',path ',lispcode)))
(defmacro p==p (path1 path2)
  `(setq x (path=remove
		(path=path (path=defined x ',path2) ',path1 ',path2)
	        ',path2)))
(defmacro p<p (path1 path2)
  `(setq x (path<path x ',path1 ',path2)))
(defmacro p<a (path atom)
  `(setq x (path<atom x ',path ',atom)))


;;; 
;;;   The following functions do the actual handling of PSEUDO
;;;  equations.
;;;
;;;  function    	example equations
;;; 
;;;  PATH=PATH 		((x0 subj) = x1), ((x1 agr) = (x2 agr)), ...
;;;  PATH=ATOMS 	((x0 mood) = imp), ((x1 tense) = (*OR* pres future))
;;;  PATH=DEFINED	((x0 obj) = *DEFINED*)
;;;  PATH=UNDEFINED	((x0 obj) = *UNDEFINED*)
;;;  PATH>PATH		((x0 ppadjunct) > x2)
;;;  PATH>ATOMS		((x0 aux) > possibility)
;;;  PATH=LISPCODE      ((x0 value) <= (+ (x2 value)(* 10 (x1 value))))
;;; 
;;;   The followings are particularly useful for generation.
;;;  PATH=REMOVE	((x0 obj) = *REMOVE*)
;;;  PATH<PATH
;;  PATH<ATOM
;;; 

(defun path=path (*fs-list* path1 path2 &aux unpacked)
    ;; unpack all f-structures so we won't have to worry about
    ;; disjunction during unification
 (setq unpacked (unpack* *fs-list* path2))
    ;; Unpack path2. If it fails due to *MULTIPLE*, try unpack path1.
    ;; If both unpackings fail, error.
 (cond ((eq unpacked '*fail*)
	(setq unpacked (unpack* *fs-list* path1))
	(cond ((eq unpacked '*fail*)
	       (format t "### (~S = ~S). Both contain *MUTLIPLE*."
		   path1 path2)
	       (return-from path=path nil))
	      (t
	       (map-dolist+ (fs unpacked)
		  (setvalue fs path2 (getvalue fs path1) :mode 'UNIFY))
	      )))
       (t 
        (map-dolist+ (fs unpacked)
             (setvalue fs path1 (getvalue fs path2) :mode 'UNIFY)))))

(defun path>path (*fs-list* path1 path2 &aux unpacked)
 (setq unpacked (unpack* *fs-list* path2))
 (cond ((eq unpacked '*fail*)
        (format t "### (~S > ~S).  Thr right path contains *MULTIPLE*"
		path1 path2)
	(return-from path>path nil)))
 (map-dolist+ (fs unpacked)
       (setvalue fs path1 (getvalue fs path2) :mode 'PUSH))) 

(defun path=atom (*fs-list* path atom)
       ;; Do unification and set the result
    (map-dolist+ (fs *fs-list*)
       (setvalue fs path atom :mode 'UNIFY)))
	     
(defun path=defined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'DEFINED)))

(defun path=undefined (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'UNDEFINED)))

(defun path=catom (*fs-list* path atom)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path atom :mode 'C-UNIFY)))

(defun path>atom (*fs-list* path atom)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path atom :mode 'PUSH)))

(defun path=remove (*fs-list* path)
   (map-dolist+ (fs *fs-list*)
     (setvalue fs path nil :mode 'REMOVE)))

(defun path<path (*fs-list* path1 path2 &aux unpacked)
 (setq unpacked (unpack* *fs-list* path2))
 (cond ((eq unpacked '*fail*)
        (format t "### (~S < ~S).  Thr right path contains *MULTIPLE*"
		path1 path2)
	(return-from path<path nil)))
 (map-dolist+ (fs unpacked)
      (let ((value (multi-value-to-list (getvalue fs path2))))
	(cond ((null value)
	       (return-from path<path nil))
	      (t 
               (setq fs (setvalue fs path1 (car value) :mode 'UNIFY))
	       (setvalue fs path2 nil :mode 'POP)
	)))))
   
;;; 
;;; PATH=LISPCODE - it uses COMPILE-LISPCODE defined below.
;;;
(defun path=lispcode (*fs-list* path expr)
 
     ;; Unpack for all paths in the lisp code (EXPR) 
  (dolist (getpath (find-paths expr))
    (setq *fs-list* (unpack* *fs-list* getpath)))

     ;;  Then GETVALUE all paths, apply the lisp code, and SETVALUE
     ;;  the result into PATH.
     ;;  Example: (setvalue fs '(x0) (+ (getvalue fs '(x2 value))
     ;;					(* 10 (getvalue fs '(x1 value)))))
     
  (map-dolist (fs *fs-list*)
    (setvalue fs path (apply `(lambda (fs) ,(compile-lispcode expr))
			  (list fs)))))


;;; _________________________________________________________________
;;;
;;; COMPILE-LISPCODE compiles (arbitrary lisp codes) equations
;;; _________________________________________________________________
;;; 
(defun compile-lispcode (expr)
  (cond ((atom expr) expr)
	((eq 'QUOTE (car expr)) expr)
	((pathp expr) `(getvalue fs ',expr))
	(t (map-dolist (e expr) (compile-lispcode e)))))

; function to isolate all (x0 ...) or (x1 ...) paths in an s-expr.

(defun find-paths (expr)
  (cond ((atom expr) nil)
	((eq 'QUOTE (car expr)) nil)
	((pathp expr) (list expr))
	(t (mapcan #'(lambda (sub-expr) (find-paths sub-expr))
		   expr))))


;;; _________________________________________________________________
;;;
;;;  COMPILE-STATEMENT - Actual compilation of a statement.
;;;   Returns a lisp function for it.
;;; _________________________________________________________________

(defun compile-statement (statement)
  (let ((part1 (first  statement))
	(part2 (second statement))
	(part3 (third  statement)))
  ; 
  ;   If it is a disjunctive statement
  ; 
    (cond ((eq part1 '*OR*)
	   `(setq x
	      (append
		,@(map-dolist (s (rest statement))
		   `(let ((x x))
			,(compile-statements s))))))
  ; 
  ;   If it is an exclusive OR statement
  ; 
          ((eq part1 '*EOR*)
	   `(setq x
	      (append-dolist (fs x)
 	       (or
		,@(map-dolist (s (rest statement))
		   `(let ((x (list fs)))
			 ,(compile-statements s)))))))
  ; 
  ;   If it is an CASE statement
  ; 
          ((eq part1 '*CASE*)
	   `(setq x
	     (append-dolist (fs x)
	      (case ,(compile-lispcode part2)
	        ,@(map-dolist (s (cddr statement))
		   `(,(car s) (let ((x (list fs)))
				,(compile-statements (cdr s)))))))))
  ; 
  ;   If it is a TEST statement	;  need to change to unpack.
  ; 
          ((eq part1 '*TEST*)
	   `(let ()
	      (setq x
	        (append-dolist (getpath ',(find-paths part2))
		  (completely-unpack* x getpath)))
	      (setq x
		(append-dolist (fs x)
		  (and ,(compile-lispcode part2) (list fs))))))
  ; 
  ;   If it is an INTERPRET statement ; need to change to unpack.
  ; 
	  ((eq part1 '*INTERPRET*)
	   `(setq x
		(append-dolist (fs x)
		  (interpret-statements (list fs)
			(apply '(lambda (fs) ,(compile-lispcode part2))
				(list fs))))))
  ; 
  ;   If length of statement is 3 and part1 is a path, then equation.
  ; 
	  ((= (length statement) 3)
           (compile-equation statement))
  ; 
  ;   Otherwise, error.
  ; 
          (t (equation-error statement)))))

;;; _________________________________________________________________
;;; 
;;;  COMPILE-EQUATION takes a pseudo equation and returns a lisp
;;;  code for it.
;;; _________________________________________________________________
;;; 
(defun compile-equation (equation)
  (let ((part1 (first  equation))
	(part2 (second equation))
	(part3 (third  equation)))
  ; 
  ;   Xn  -->  (Xn)
  ;
    (if (resisterp part1) (setq part1 (list part1)))
    (if (resisterp part3) (setq part3 (list part3)))

  ; 
  ;   Branch by part2
  ; 
	   (case part2
	     (=
	       (cond ((pathp part3)
		      `(P=P ,part1 ,part3))
		     ((eq part3 '*DEFINED*)
		      `(P=D ,part1))
		     ((eq part3 '*UNDEFINED*)
		      `(P=U ,part1))
		     ((eq part3 '*REMOVE*)
		      `(P=R ,part1))
		     ((or (atom part3) (atom (car part3)))
		      `(P=A ,part1 ,part3))
		     (t (equation-error equation))))

	     (=c
	      (cond ((pathp part3)
		     (equation-error equation))
		    ((or (atom part3) (atom (car part3)))
		     `(P=CA ,part1 ,part3))
		     (t (equation-error equation))))

	     (>
	       (cond ((pathp part3)
		      `(P>P ,part1 ,part3))
		     ((or (atom part3) (atom (car part3)))
		      `(P>A ,part1 ,part3))
		     (t (equation-error equation))))

	     (<=
	       `(P=L ,part1 ,part3))

 	     (==
	       (cond ((pathp part3)
		      `(P==P ,part1 ,part3))
		     (t (equation-error equation))))

	     (<
	       (cond ((pathp part3)
		      `(P<P ,part1 ,part3))
		     ((or (atom part3) (atom (car part3)))
		      `(P<A ,part1 ,part3))
		     (t (equation-error equation))))
	     (t
	       (cond ((member part2 *user-defined-equation*)
		      (compile-statements
		        (macroexpand (list part2 part1 part3))))
		     (t (equation-error equation)))))))

;;;
;;;	COMPILE-STATEMENTS
;;;     Returns a list of lisp functions
;;;
(defun compile-statements (statements)
 `(and
   ,@(map-dolist (statement statements)
	(compile-statement statement))))

;;; __________________________________________________________
;;; 
;;;   Functions to Interpret (Evaluate) Pseudo Equations
;;; __________________________________________________________
;;; 

;;; 
;;;  INTERPRET-EQUATION executes one equation.
;;; 
(defun interpret-equation (x equation)
  (apply `(lambda (x) ,(compile-equation equation)) (list x)))

;;; 
;;;  INTERPRET-LISPCODE evaluates a lisp expression possibly
;;;  with paths inside.
;;; 
(defun interpret-lispcode (fs expr)
  (apply `(lambda (fs) ,(compile-lispcode expr)) (list fs)))

;;; 
;;;  INTERPRET-STATEMENT executes one statement.
;;; 
(defun interpret-statement (x statement)
  (let ((part1 (first statement))
	(part2 (second statement))
    	(part3 (third statement)))
  ; 
  ;   If it is a disjunctive statement
  ; 
    (cond ((eq part1 '*OR*)
	   (setq x
	      (append-dolist (s (rest statement))
		 (interpret-statements x s))))
  ; 
  ;   If it is an exclusive OR statement
  ; 
          ((eq part1 '*EOR*)
	   (setq x
	      (append-dolist (fs x)
		(or-dolist (s (rest statement))
		   (interpret-statements (list fs) s)))))
  ; 
  ;   If it is an CASE statement
  ; 
          ((eq part1 '*CASE*)
	   (append-dolist (fs x)
	       (let ((key (interpret-lispcode fs part2)))
		  (interpret-statements (list fs)
					(cdr (assoc key (cddr statement))))
	       )))
  ; 
  ;   If it is an exclusive TEST statement
  ; 
          ((eq part1 '*TEST*)
           (print part2)
           (setq x 
	     (append-dolist (getpath (find-paths part2))
		    (completely-unpack* x getpath)))
           (append-dolist (fs x)
		  (and (interpret-lispcode fs part2) (list fs))))

;;;   If it is a recursive evaluation of equations
;;; 
	  ((eq part1 '*INTERPRET*)
           (append-dolist (fs x)
		  (interpret-statements
			   (list fs) (interpret-lispcode fs part2))))

  ; 
  ;   If length of statement is 3 and part1 is a path, then equation.
  ; 
	  ((= (length statement) 3)
           (interpret-equation x statement))
  ; 
  ;   Otherwise, error.
  ; 
          (t (equation-error statement)))))
 
;;; 
;;;  INTERPRET-STATEMENTS executes a list of statements.
;;; 
(defun interpret-statements (x statements)
  (and-dolist (statement statements)
	(setq x (interpret-statement x statement))))
    


;;; _________________________________________________________________
;;; 
;;;  Unpacking a packed f-structure.  Returns a fs-list,
;;;  or *FAIL*, if it can't unpack (with *MULTIPLE*)
;;; _________________________________________________________________
;;; 
(defun unpack* (fs-list path)
	 (append-dolist (fs fs-list)
	   (let ((result (unpack fs path)))
	    (if (eq result '*fail*) (return-from unpack* '*fail*) result))))

(defun unpack (fs path)			; returns a fs-list or *FAIL*
  (prog (sub-fs unpacked-sub-fs-list)
       ;; if (length path) is 1, no need to unpack
	(if (equal (length path) 1) (return (value-to-list fs)))
       ;; if fs is a *MULTIPLE* value, fail.				 
  	(if (eq (car fs) '*MULTIPLE*) (return '*fail*))
       ;; get sub f-structure
    (setq sub-fs (second (assoc (car path) fs)))
       ;; if sub-fs is undefined, no need to unpack
    (if (null sub-fs) (return (list fs)))
    (if (not (listp sub-fs)) (return (list fs))) ;;tomabech

    (setq unpacked-sub-fs-list
        (cond
             ;; if sub-fs is a *OR* list
          ((eq (car sub-fs) '*OR*)
            (append-dolist (sub-fs-1 (cdr sub-fs))
	      (let ((result (unpack sub-fs-1 (cdr path))))
		(if (eq result '*fail*)
		    (return-from unpack '*fail*)
		    result))))
             ;; if sub-fs is a *MULTIPLE* value
          ((eq (car sub-fs) '*MULTIPLE*)
	   (return-from unpack '*fail*))
             ;; if sub-fs is a single value
          (t
           (unpack sub-fs (cdr path)))))
    (return
      (map-dolist (unpacked-sub-fs unpacked-sub-fs-list)
        (setvalue fs (list (car path)) unpacked-sub-fs)))))

;;;
;;;  UNPACK* does not unpack the last slot of PATH, while
;;;  COMPLETELY-UNPACK* does.  Used for *TEST* and *INTERPRET*
;;;  statements.
;;;
(defun completely-unpack* (fs-list path)
  (unpack* fs-list (append path '(DUMMY))))

;;; __________________________________________________________________
;;; 
;;;  GETVALUE gets a value from a f-structure.
;;;  No need to worry about *OR*, as already unpacked.
;;; __________________________________________________________________
;;; 
(defun getvalue (fs path)   ; returns a fs; or nil if undefined
 (cond ((not (listp fs)) nil)
       (t (let ((assoc-result (second (assoc (car path) fs))))
           (cond 
        ;; if assoc-result is nil, return nil
             ((null assoc-result) nil)
        ;; if path length is 1, return assoc-result
             ((eq (length path) 1) assoc-result)
        ;; otherwise call getvalue recursively
             (t (getvalue assoc-result (cdr path))))))))

;;;
;;;  GETVALUE* is used at the end of each augmentation function.
;;;
(defun getvalue* (fs-list path)
    (list-to-value   
	(append-dolist (fs fs-list)
	   (value-to-list (getvalue fs path)))))

;;; __________________________________________________________________
;;; 
;;; SETVALUE
;;;  Setting a value (val) to a particular slot (path) of
;;;  a f-structure (fs).
;;; __________________________________________________________________
;;; 
;;;  There are 8 modes as follow:
;;; 
;;; OVERWRITE (default)  for ((xn ..) <= value)
;;;  If a value already exists, overwrite.
;;;
;;; UNIFY  for ((xn ..) = value)
;;;  If a value already exists, unify it with the new value.
;;;  If unify returns *FAIL*, then fail.
;;;
;;; C-UNIFY  for ((xn ..) =c value)
;;;  Same as UNIFY mode, except it fails if a value doesn't
;;;  already exists.
;;;
;;; DEFINED  for ((xn ..) = *DEFINED*)
;;;  If a value doesn't already exists, fail.
;;;  Otherwise, return fs.  Argument val is dummy.
;;;
;;; UNDEFINEDP   for ((xn ..) = *UNDEFINED*)
;;;  If a value already exists, fail.
;;;  Otherwise, return fs. Argument val is dummy.
;;;
;;; PUSHVALUE  for ((xn ..) > value)
;;;  If values already exists, append val to them.
;;;
;;; REMOVE  for ((x0 ..) = *REMOVE*) or ((xn ..) == (xm ..))
;;;  Remove the value (and the slot).
;;; 
;;; POP for ((xn ..) < (xm ..))
;;;  Pop (remove the first element of) the value.  If the value is
;;;  nil, return nil.
;;; 
(defun setvalue (fs path val &key (mode 'OVERWRITE))  ; returns a fs
  (cond
      ((null path)
 	 (case mode
	  (OVERWRITE val)
   	  (UNIFY (unify fs val))
	  (C-UNIFY (if fs (unify fs val) '*FAIL*))
	  (DEFINED (if fs fs '*FAIL*)) 
	  (UNDEFINED (if fs '*FAIL* nil))
	  (PUSH (append-fs-to-fs fs val))
	  (REMOVE nil)
	  (POP (pop-multi-value fs))))

         ;; if fs is *OR*, do each of the disjunction.
         ;; Return *fail* when all of the disjunction fail.
      ((and (listp fs)(eq (car fs) '*OR*))
       (or
        (list-to-value
	 (map-dolist+ (fs1 (cdr fs))
 	  (setvalue fs1 path val :mode mode)))
        '*FAIL*))

         ;; if fs is *MULTIPLE*, do each of the conjunction.
         ;; Return *fail* when any one of the disjunction fails.
      ((and (listp fs)(eq (car fs) '*MULTIPLE*))
       (let ((newvalue nil))
         (setq newvalue
           (map-dolist (fs1 (cdr fs))
 	   (setvalue fs1 path val :mode mode)))
         (if (member '*FAIL* newvalue)
             '*FAIL*
             (cons '*MULTIPLE* newvalue))))
          
         ;; else take ASSOC
      (t (let ((assoc-result (assoc (car path) fs)))
	  (if
            (null assoc-result)
	      ;; If the path doesn't exist	
	    (case mode
	      ((OVERWRITE UNIFY PUSH) (append (create-path path val) fs))
	      ((C-UNIFY DEFINED) '*FAIL*)
	      ((UNDEFINED REMOVE) fs))
	      
	       ;; If the path exists, call setvalue recursively
	    (let ((rec-result (setvalue (second assoc-result)
					(cdr path) val :mode mode)))
              (cond ((eq rec-result '*FAIL*) '*FAIL*)
		    ((null rec-result)(remove assoc-result fs))
	            ((cons (list (car path) rec-result)
			(remove assoc-result fs))))))))))

;;; 
;;; CREATE-PATH is used by SETVALUE
;;;  e.g. (create-path '(f1 f2) 'v1) ==> ((f1 ((f2 v1))))
;;;
(defun create-path (path val)
 (cond ((= (length path) 1)(list (list (car path) val)))
       (t (list (list (car path)(create-path (cdr path) val))))))
;;;
;;;  APPEND-FS-TO-FS appends two multiple values.
;;;
(defun append-fs-to-fs (fs1 fs2)
   (cond ((null fs1) fs2)
	 ((multi-p fs1)
	  (cond ((null fs2) fs1)
		((multi-p fs2) (cons '*MULTIPLE*
				     (cons (cdr fs2) (cdr fs1))))
		(t (cons '*MULTIPLE* (cons fs2 (cdr fs1))))))
	 (t
	  (cond ((multi-p fs2) (cons '*MULTIPLE* 
				     (cons fs2 (cdr fs1))))
	   	(t (list '*MULTIPLE* fs2 fs1))))))

;;; ___________________________________________________________________
;;; 
;;;  UNIFICATION functions
;;; ___________________________________________________________________

;;; 
;;;  UNIFY is the top level unification function.
;;; 
(defun unify (fs1 fs2) ; returns a fs or *fail*
  (cond ((null fs1) fs2)
	((null fs2) fs1)
 	((multi-p fs1) (unify*multiple* fs1 fs2))
 	((multi-p fs2) (unify*multiple* fs2 fs1))
	((or-p fs1) (unify*OR* fs1 fs2))
	((or-p fs2) (unify*OR* fs2 fs1))
	((not-p fs1) (unify*NOT* fs1 fs2))
	((not-p fs2) (unify*NOT* fs2 fs1))
     	((user-p fs1)(unify-user-values fs1 fs2))
	((user-p fs2)(unify-user-values fs2 fs1))
	((atom fs1) (if (equal fs1 fs2) fs2 '*fail*))
	((atom fs2) '*fail*)
	(t (unify-fs fs1 fs2))))
 	
;;;
;;; UNIFY-FS does the tree to tree (fs-to-fs) unification.
;;;
(defun unify-fs (fs1 fs2)  ; returns a new fs
  (prog (new-fs sub-fs)
    (dolist (slot-value fs1)
      (let* ((slot (car slot-value))
	     (value (second slot-value))
	     (assoc-result (assoc slot fs2)))
	(cond (assoc-result 
	       (setq sub-fs (unify value (second assoc-result)))
               (if (eq sub-fs '*fail*) (return-from unify-fs '*fail*))
   	       (push (list slot sub-fs) new-fs)
	       (setq fs2 (remove assoc-result fs2)))
	      (t
	       (push slot-value new-fs)))))
    (return (append new-fs fs2))))

;;; 				
;;; UNIFY*OR* calls UNIFY with all possible combinations
;;; of fs-list1.
;;; 
(defun unify*or* (fs1 fs2 &aux result)
   (setq result
         (append-dolist (f (cdr fs1))
	     (value-to-list (unify f fs2))))
   (setq result (remove '*fail* result))
   (if result (list-to-value result) '*fail*))

;;; 
;;;  UNIFY*MULTIPLE* takes fs1 and fs2, where fs1 is a *multiple* value.
;;;  Unify fs2 with each element of fs1.  If any one
;;;  fails, it returns *fail*.  Otherwise, return the list
;;;  of results.
;;; 
(defun unify*multiple* (fs1 fs2 &aux result)
  (setq result
      (append-dolist (f (cdr fs1))
	(multi-value-to-list (unify f fs2))))
  (if (member '*fail* result) '*fail* (list-to-multi-value result)))

;;; 
;;;  UNIFY*NOT* takes fs1 and fs2, where fs1 is a *not* value.
;;;  If fs2 is a *not* value, take union.
;;;  Unify fs2 with each element of fs1.  If any one does NOT fail,
;;;  it returns *FAIL*; If all fail, it returns fs2.
;;; 
(defun unify*not* (fs1 fs2 &aux result)
 (cond
  ((not-p fs2)
   (cons '*NOT* (union (cdr fs1) (cdr fs2) :test #'equal)))
  (t 
   (setq result
       (append-dolist (f (cdr fs1))
	 (value-to-list (unify f fs2))))
   (setq result (remove '*FAIL* result))
   (if result '*FAIL* fs2))))

;;; 
;;;  UNIFY-USER-VALUES unifies two user-defined special values.
;;; 
(defun unify-user-values (fs1 fs2)
  (apply (intern (concatenate 'string "UNIFY"
			 (symbol-name (car fs1))))
	 (list fs1 fs2)))
;;;	INC-NUMS-IN-ACTION-TABLE - Increment numbers in an action table
;;;   1. increment state # of index by INC-STATE-NO
;;;   2. increment state # of shift-action by INC-STATE-NO
;;;   3. increment state # of reduce-action by INC-RULE-NO
;;;
(defun inc-nums-in-action-table (action-table inc-state-no inc-rule-no)
  (dolist (action-table-one-row action-table)
       ;; increment index by inc-state-no
    (incf (car action-table-one-row) inc-state-no)
    (dolist (action-table-one-entry (cdr action-table-one-row))
     (dolist (action (cdr action-table-one-entry))
      (case (car action)
	   ;; if shift, increment state # by inc-state-no
  	(s (incf (cdr action) inc-state-no))
           ;; if reduce, increment rule # by inc-rule-no
	(r (incf (cdr action) inc-rule-no))
	   ;; if accept, do nothing
	(a nil)))))
  action-table)			;; return the new action table


;;;	INC-NUMS-IN-GOTO-TABLE - Increment numbers in a goto table
;;;   1. increment state # of index by INC-STATE-NO
;;;   2. increment state # of goto-action by INC-STATE-NO
;;;
(defun inc-nums-in-goto-table (goto-table inc-state-no)
  (dolist (goto-table-one-row goto-table)
       ;; increment index by inc-state-no
    (incf (car goto-table-one-row) inc-state-no)
    (dolist (goto-table-one-entry (cdr goto-table-one-row))
     (incf (cdr goto-table-one-entry) inc-state-no)))
  goto-table)			;; return the new goto table


;;;	MERGE-TWO-TABLE-ROWS - Merge two rows of action or goto table
;;;  ex. (setq r1 '(3 (a ACTION1 ACTION2)(b ACTION3 ACTION4)))
;;;      (setq r2 '(200 (b ACTION4 ACTION5)(c ACTION6)))
;;;      (merge-two-table-rows r1 r2) ===>
;;;	   (3 (a ACTION1 ACTION2)(b ACTION3 ACTION4 ACTION5)(c ACTION6))
;;;	 Note: r1 is destructed.
;;;
(defun merge-two-table-rows (row1 row2)
  (let ((entries1 (cdr row1))
	(entries2 (cdr row2)))
   (dolist (entry2 entries2)
     (let ((entry1 nil))
      (setq entry1 (assoc (car entry2) entries1))
      (if entry1
	  ;; If the same column exists, merge actions
       (setf (cdr entry1)
         (union (cdr entry1)(cdr entry2) :test #'equal))
	  ;; If the same column doesn't exist, create one
       (setf (cdr (last entries1)) (list entry2)))))
  row1))

;;;	MODIFY-ACTION-TABLE - modify the parent action table
;;;
(defun modify-action-table
        (action-table goto-table non-terminal new-actions)
  (dolist (g-row goto-table)
   (when (assoc non-terminal (cdr g-row))
      (merge-two-table-rows
	 (assoc (car g-row) action-table)
	 new-actions)))
  t )   ;; return t.
             
;;;	TABLE-MERGE - Merging sub-tables and main-table
;;;
(defun table-merge (parent-table sub-table-list)
 (format t "~%~%*****************************************~%")
 (format t "***** Table Merge started~%")
 (let* ((parent-grammar-table (first parent-table))
        (parent-action-table (second parent-table))
        (parent-goto-table (third parent-table))
        (inc-state-no (length parent-action-table))
        (inc-rule-no (length parent-grammar-table))
        (sub-grammar-table* nil)
        (sub-action-table* nil)
        (sub-goto-table* nil))
  (dolist (sub-table sub-table-list)
   (let* ((sub-grammar-table (first sub-table))
	  (sub-action-table (second sub-table))
	  (sub-goto-table (third sub-table))
	  (sub-start-symbol (caar sub-grammar-table)))
    (format t "*** Merging Table for ~A~%" sub-start-symbol)
    (setq sub-action-table*
     (append sub-action-table* 
      (inc-nums-in-action-table sub-action-table inc-state-no inc-rule-no)))
    (setq sub-goto-table*
     (append sub-goto-table* 
      (inc-nums-in-goto-table sub-goto-table inc-state-no)))
    (setq sub-grammar-table*
     (append sub-grammar-table* sub-grammar-table))
    (setq parent-action-table (copy-tree parent-action-table))
    (modify-action-table
	 parent-action-table
	 parent-goto-table
	 sub-start-symbol
	 (car sub-action-table))
    (incf inc-state-no (length sub-action-table))
    (incf inc-rule-no (length sub-grammar-table))
  ))
  (format t "***** Table Merge done~%")
  (list (append parent-grammar-table sub-grammar-table*)
 	(append parent-action-table sub-action-table*)
	(append parent-goto-table sub-goto-table*))))

   
       
;;;;; -*- mode: lisp; syntax: common-lisp; package: cl-user; base: 10 -*- ;;;;
;;;;;
;;;;;	    	GRA-PREPROCESS - Grammar Pre-processor
;;;;;		  for system version 8-2
;;;;; 		  Mostly Grammar Macro Expansion

;;;;;		  by Masaru Tomita 6/2/87
;;;;;
;;;
;;; 	Pre-process one rule
;;;
(defun rule-preprocess (rule)
  (cond
	   ;; If macro or function definition, do define.
	   ;;
        ((member (car rule) (list 'defmacro 'defun 'defequation)) (eval rule) nil)

	   ;; If sub-grammar inclusion, ignore.
	   ;;
	((member (car rule) (list '@lex '@gra)) nil)

           ;; If macro call, expand the macro.
	   ;;
        ((macro-function (car rule))
	 (mapcan #'rule-preprocess (macroexpand rule)))

	   ;; Make sure that the rule is for parsing by looking at
	   ;; its arrow.  If so, return the rule (without arrow).
	   ;;
	((member (second rule) (list '<==> '<--> '<== '<--))
	 (list (list (first rule)
		     (third rule) 
                     (fourth rule))))

	   ;; Otherwise, return nil.
	   ;;
        (t nil)))

;;;
;;;	Pre-process all rules in grammar
;;;	called by COMPSUB in compgra.lisp
;;;
(defun gra-preprocess (rule-list &aux result)
  (format t "*** Grammar Pre-processor started~%")
  (setq result (mapcan #'rule-preprocess rule-list))
  (format t "*** Grammar Pre-processor done~%")
  result)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;	Utility functions used in grammar macros
;;;;

;;;   EXPLODE-STRING and EXPLODE-INPUT-STRING defined in UTIL.LISP
;;;    (explode-string "tomita") ==> (t o m i t a)
;;;
;(defun explode-string (instring)
;  (explode-input-string (remove #\  instring)))
;
;(defun explode-input-string (string)
;  (map 'list #'(lambda (char) (intern (string (char-upcase char)))) string))

;;;    (root-symbol "get rid of") ==> GET-RID-OF
;;;
(defun root-symbol (instring)
  (intern (string-upcase (substitute #\- #\space instring))))

;;;    Find @lex's and @gra's in .mgra file, and returns a list of
;;;    a list of sub-lex-files and a list of sub-gra-files.
;;;
(defun find-sub-files (mgra-file)
   (let ((mgra (read-file-list mgra-file))
	 (sub-lex-files nil)
	 (sub-gra-files nil))
     (dolist (rule mgra)
	(cond ((eq '@lex (car rule))
	       (setq sub-lex-files (append (cdr rule) sub-lex-files)))
	      ((eq '@gra (car rule))
	       (setq sub-gra-files (append (cdr rule) sub-gra-files)))))
     (if sub-lex-files 
	 (format t " - Lexical Files = ~S~%" sub-lex-files))
     (if sub-gra-files 
	 (format t " - Sub Grammar Files = ~S~%" sub-gra-files))

     (list sub-lex-files sub-gra-files)))
     
;;; _______________________________________________________________
;;; 
;;;   GLOBAL VARIABLES
;;; _______________________________________________________________
;;; 

;;; 
;;; 1 dim array of a set of items.
;;; 
(defvar *chart*)

;;; 
;;; 1 dim array of grammar rule.
;;; 
(defvar *rules*)

;;; 
;;; hash-table of rules indexed by lhs.
;;; 
(defvar *rule-hash*)

;;; 
;;; *WORD-POS* is an interger and indicates the current word position.
;;; 
(defvar *word-pos*)

;;;
;;; *SENTENCE* contains an input string.
;;; *INPUT-BUFFER* is a list of input symbols.  It will be popped off,
;;;    and eventually faded out.
;;;  
(defvar *sentence* "")
(defvar *input-buffer*)

;;; 
;;; structure ITEM
;;; 
(defstruct item
  (rule nil)			; An APSG rule
  (afterdot nil)		; Right hand side symbols after the dot
  (origin 0)			; origin of the item
  (f-structs nil))		; f-structures built so far

;;; 
;;; *CURRENT-ITEM* contains an item being processed.
;;; *ITEMS-PROCESSED* contains items already processed.
;;; *ITEMS-TO-PROCESS* contains items yet to process.
;;; 
(defvar *current-item*)
(defvar *items-processed*)
(defvar *items-to-process*)

;;; 
;;; *NON-TERMINALS* contains all non-terminal symbols.
;;; 
(defvar *non-terminals*)

;;; 
;;; *START-SYMBOL* contains the start symbol of a grammar.  It is
;;; defined to be the lhs symbol of the very first grammar rule.
;;; *SYSTEM-START-SYMBOL* contains a symbol which is internally used
;;; by the system.
;;; 
(defvar *start-symbol*)
(defparameter *system-start-symbol* '<system-start>)

;;;
;;; *WILD-CARD-CHARACTER* contains the symbol for the wild-card,
;;;  which can match any terminal symbols.
;;;
(defparameter *wild-card-character* '%)

;;; 
;;; *DEBUG-LEVEL* from 0 to 2.
;;;   Level 1 prints shifted words.
;;;   Level 2 prints shifted words and rule applications.
;;;   Can be set by (dmode n).
;;; 
(defvar *debug-level* 0)

;;;
;;; *TRACED-RULES* contains a list of (rule-no begin end) to trace
;;;  augmentation.
;;;
(defvar *traced-rules* nil)


;;; _______________________________________________________________
;;; 
;;;   I/O FUNCTIONS
;;; _______________________________________________________________

;;; 
;;;    I-LOADGRA takes one or more file name (stem only), and
;;;    load them for the runtime parser.
;;; 
(defun i-loadgra (gra-file &rest more-gra-files)
 (let ((rule-list nil) (rule-count 0))
  (setq rule-list
     (append-dolist (file (cons gra-file more-gra-files))
	(read-rules (concatenate 'string file ".gra"))))
  (setq *rules* (make-array (list (length rule-list))
			 :initial-contents rule-list))
  (setq *rule-hash* (make-hash-table))
  (setq *non-terminals* nil)
;  (push `(,*system-start-symbol* <-- (,*start-symbol* $) nil) 
;	(gethash *start-symbol* *rule-hash*))
  (dolist (rule rule-list)
    (setq *non-terminals* (union *non-terminals* (list (first rule))))
    (incf rule-count)
    (push (append rule (list rule-count))
	  (gethash (first (third rule)) *rule-hash*)))))

;;; 
;;;    READ-RULES reads a grammar (list of rules), and
;;;    each rule is preprocessed.
;;; 
(defun read-rules (file &aux (subfiles nil))
 (let ((rule-list nil))
  (format t "***** Start Reading ~A~%" file)
  (with-open-file (ifile file :direction :input)
    (do ((rule (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq rule '%eof%))
      (if (member (car rule) '(@lex @gra))
	  (setq subfiles (append subfiles (cdr rule))))
      (setq rule-list (append rule-list (i-rule-preprocess rule)))))
  (format t "***** End Reading ~A~%" file)
  (dolist (subfile subfiles)
     (setq rule-list
	 (append rule-list
		 (read-rules (concatenate 'string subfile ".gra")))))
  rule-list))


;;; ________________________________________________________________
;;;
;;;   I-RULE-PREPROCESS preprocesses one rule.  This is slightly
;;;   different from RULE-PREPROCESS for lr-table-compiler; 
;;;   I-RULE-PREPROCESS preserves arrows.
;;;
(defun i-rule-preprocess (rule)
  (cond
	   ;; If macro or function definition, do define.
	   ;;
        ((member (car rule) (list 'defmacro 'defun 'defequation))
	 (eval rule) nil)

	   ;; If sub-grammar inclusion, ignore. They are handled
           ;; in READ-RULES.			
	   ;;
	((member (car rule) (list '@lex '@gra)) nil)

           ;; If macro call, expand the macro.
	   ;;
        ((macro-function (car rule))
	 (mapcan #'i-rule-preprocess (macroexpand rule)))

	   ;; Make sure that the rule is for parsing by looking at
	   ;; its arrow.  If so, return the rule (without arrow).
	   ;;
	((member (second rule) (list '<==> '<--> '<== '<--))
         (list rule))

	   ;; Otherwise, return nil.
	   ;;
        (t nil)))

;;;
;;;  USER-DEFINED-EQUATION
;;;
(defvar *user-defined-equation* nil)

(defmacro defequation (eq body)
    (if (not (member eq *user-defined-equation*))
	(push eq *user-defined-equation*))
    `(defmacro ,eq (lhs rhs) ,body))

;;; _________________________________________________________________
;;; 
;;;      TOP-LEVEL FUNCTIONS
;;; _________________________________________________________________


(defun init-i-parse ()
  (setq *word-pos* 0)
  (setq *start-symbol* (first (aref *rules* 0)))
  (let* ((dummy-rule `(,*system-start-symbol* <-- (,*start-symbol* $) nil))
	 (initial-item (make-item :rule dummy-rule
				  :afterdot (list *start-symbol* '$)
				  :origin 0
				  :f-structs nil)))
    (setq *items-to-process* (list initial-item)))
  (setq *chart* (make-array (list (1+ (length *input-buffer*)))))
  (setq *current-item* nil)
  (setq *items-processed* nil))

(defun finish-i-parse (&aux result-f-structures)
   (setf (aref *chart* *word-pos*) *items-processed*)
   (dolist (item *items-processed*)
	(if (and (null (item-afterdot item))
		 (eq 0 (item-origin item))
		 (eq (car (item-rule item)) *system-start-symbol*))
 	    (setq result-f-structures
 	       (append (value-to-list (car (item-f-structs item)))
		       result-f-structures))))
   (list-to-value result-f-structures))


(defun i-parse-list (sentence) 	; list of symbols
   (setq *input-buffer* sentence)
   (init-i-parse)
   (process-column)
   (do () ((null *input-buffer*) t)
     (shift-word)
     (if (null *items-to-process*)(i-parse-error))
     (process-column))
   (finish-i-parse))

(defun ip (&optional (string *sentence*))
  (setq *sentence* string)
  (format t "~3&>~a~&" string)
  (i-parse-list (append (explode-string string) '($)))
  )

(defun disp-rule-application (rule f-structs new-f-structs)
 (let* ((rule-no (fifth rule))
        (trace-attr (cdr (assoc rule-no *traced-rules*)))
        (i 0))
  (when (>= *debug-level* 2) 
        (format t "~&apply #~a: ~a ~a ~a "
		(fifth rule)(first rule)(second rule)(third rule))
    (if new-f-structs (format t "~%") (format t "-Killed~%")))
  (when (and trace-attr
	     (<= (first trace-attr) *word-pos*)
	     (>= (second trace-attr) *word-pos*))
    (format t "~&---- RULE #~a ----~%" rule-no)
    (format t "~&AUGMENTATION:~%")
    (princ (fourth rule))
    (dolist (f-struct f-structs)
      (incf i)
      (format t "~&X~a:~%" i)
      (princ f-struct))
    (format t "~&RESULT:~%")
    (princ (list-to-value new-f-structs))
    (terpri))))

;;; ________________________________________________________________
;;;
;;;   DEBUGGING TOOLS
;;; ________________________________________________________________
;;;

(defun trace-rule (rule-no &optional (begin 0) (end 500))
  (push (list rule-no begin end) *traced-rules*)
  t)

(defun untrace-rule ()
  (setq *traced-rules* nil))

(defun disp-def (rule-no)
  (print (nth (1- rule-no) *rules*)))

(defun dmode (n)
  (setq *debug-level* n))

;;; ________________________________________________________________
;;;
;;;   INTERFACE TO PSEUDO-UNIFICATION
;;; ________________________________________________________________
;;;

;;; 
;;; CONSTIT-LIST - used in COMPILE-AUGMENTATION.
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;;
;;;	   COMPILE-AUGMENTATION 
;;;	    rhs-len : the length of right hand side
;;;	    statements : list of LFG equations
;;;        Returns (lambda (x1 x2 ..) ..lisp-code..)
;;;
(defun compile-augmentation (rhs-len statements)
  (declare (fixnum rhs-len))
  (let* ((reg-list            (subseq CONSTIT-LIST 1 (1+ rhs-len)))
	 (compiled-statements (compile-statements statements))
	 (used-regs           (collect-registers compiled-statements))
	 (not-used-regs       (set-difference reg-list used-regs))
	 (cons-list           (make-cons-list used-regs)))
    (append
      `(lambda ,reg-list)
      (when not-used-regs ; if there is registers for no use
	`((declare (ignore ,@not-used-regs))))
      `((let ((x (list (list ,@cons-list))))
	  (and ,compiled-statements
	       (or (getvalue* x '(x0)) t)))))))

;;;;;     collect-registers()
(defvar *register-bag*)
(defun collect-registers-sub (form)
  (if (atom form)
      (when (and (registerp form)
		 (not (eq form 'x0)))
	(pushnew form *register-bag*))
      (dolist (f form)
	(collect-registers-sub f))))

(defun collect-registers (form)
  (setq *register-bag* nil)
  (collect-registers-sub form)
  *register-bag*)


(defun make-cons-list (reg-list)
  (mapcar #'(lambda (reg) `(list (quote ,reg) ,reg)) reg-list))

(defun registerp (x)
   (member x CONSTIT-LIST))


;;; ________________________________________________________________
;;; 
;;;   FUNCTIONS FOR THE LEFT-CORNER ALGORITHM
;;; ________________________________________________________________

;;; 
;;;  PROCESS-COLUMN processes one word (or one column in *CHART*).
;;;    If *item-to-process* is nil, return.
;;;    Else, select (and remove) one item out of *item-to-process*,
;;;    and call it *current-item*.  Call PROCESS-ITEM on it.
;;; 
(defun process-column ()
  (loop
     (if (null *items-to-process*)(return *word-pos*))
     (setq *current-item* (select-item-to-process *items-to-process*))
     (setq *items-to-process* (remove *current-item* *items-to-process*))
     (process-item *current-item*)))

;;; 
;;;  PROCESS-ITEM process one item.  If its dot is at the end of rhs,
;;;     the item is complete and call COMPLETER.  Put the item into
;;;     *items-processed*.
;;; 
(defun process-item (item)
    (cond ((null (item-afterdot item))
	   (completer item))
          (t (push item *items-processed*))))

;;; 
;;;  SHIFT-ITEMS copies all items in COLUMN whose symbol right after the
;;;     dot is SYMBOL, and put them into the current column. In doing
;;;     so, the dot is advanced one position, and F-STRUCTURE is
;;;     appropriately appended to each item.  Also, create new items
;;;     for all rules whose first symbol in rhs is SYMBOL.
;;; 
(defun shift-items (column symbol f-structure)
   (dolist (item (aref *chart* column))
       (if (eq (car (item-afterdot item)) symbol)
	   (push (make-item :rule (item-rule item)
			    :afterdot (cdr (item-afterdot item))
			    :origin (item-origin item)
			    :f-structs (append (item-f-structs item)
					       (list f-structure)))
		 *items-to-process*)))
   (dolist (rule (gethash symbol *rule-hash*))
       (push (make-item :rule rule
			:afterdot (cdr (third rule))
			:origin column
			:f-structs (list f-structure))
	     *items-to-process*))
  *items-to-process*)

;;; 
;;;  COMPLETER
;;; 
(defun completer (item)
  (let* ((reduce-symbol (car (item-rule item)))
	 (pseudo-equations (fourth (item-rule item)))
	 (aug-function (compile-augmentation (length (third (item-rule item)))
					     pseudo-equations))
	 (new-f-structures (value-to-list
				 (apply aug-function (item-f-structs item))))
	 (items-to-process *items-to-process*))
   (disp-rule-application (item-rule item)
			  (item-f-structs item)
			  new-f-structures)
   (push item *items-processed*)

   (when new-f-structures
    (setq *items-to-process* nil)	 
    (dolist (item1 items-to-process)
        (if (and (null (item-afterdot item1))
		 (eq (item-origin item) (item-origin item1))
		 (equal (item-rule item) (item-rule item1)))
   	 (let* ((pseudo-equations1 (fourth (item-rule item1)))
	 	(aug-function1 (compile-augmentation
					 (length (third (item-rule item1)))
					 pseudo-equations1))
		(new-f-structures1
		        (value-to-list (apply aug-function1
				       (item-f-structs item1)))))
  	    (disp-rule-application (item-rule item1)
				   (item-f-structs item1)
				   new-f-structures1)
	    (setq new-f-structures
		   (append new-f-structures new-f-structures1))
;(print (list '***** item1 *items-processed*))
   	    (push item1 *items-processed*))
	 (push item1 *items-to-process*))))
    (when new-f-structures
      (shift-items (item-origin item)
		   reduce-symbol
		   (list-to-value (remove-duplicates new-f-structures
						     :test #'equal))))))

;;; 
;;;  SHIFT-WORD is called at the end of each PROCESS-COLUMN.
;;; 
(defun shift-word ()
   (setf (aref *chart* *word-pos*) *items-processed*)
   (setq *items-processed* nil)
   (setq *items-to-process* nil)
   (incf *word-pos*)
   (shift-items (1- *word-pos*) (car *input-buffer*) nil)
   (shift-items (1- *word-pos*) *wild-card-character*
		`((value ,(car *input-buffer*))))
   (when (>= *debug-level* 1)
     (format t "~&~2D: ~a~%"  *word-pos* (car *input-buffer*)))
   (pop *input-buffer*))

;;; 
;;;  SELECT-ITEM-TO-PROCESS selects one item to process out of 
;;;     *items-to-process*.  Select any item other than complete
;;;     items (items that trigger COMPLETER).  If all items are
;;;     complete items, select one with the latest origin (so
;;;     the most local completion will be performed first).
;;;     This is important with local-ambiguity packing.
;;; 
(defun select-item-to-process (items)
 (let ((best-item (make-item :origin -1)))
  (dolist (item items)
    (if (item-afterdot item) (return-from select-item-to-process item))
    (if (< (item-origin best-item)(item-origin item)) (setq best-item item)))
  best-item))

(defun non-term-p (symbol)
  (member symbol *non-terminals*))

(defun i-parse-error () (Print "### ERROR ###")
     (print *input-buffer*)(setq *input-buffer* nil))


;;;    (explode-string "tomita") ==> (t o m i t a)
;;;
(defun explode-string (instring)
  (explode-input-string (remove #\  instring)))

(defun explode-input-string (string)
  (map 'list #'(lambda (char)
		 (case char
		   (#\0 0)(#\1 1)(#\2 2)(#\3 3)(#\4 4)(#\5 5)
		   (#\6 6)(#\7 7)(#\8 8)(#\9 9)
		   (t (intern (string (char-upcase char))))))
       string))
;;; ________________________________________________________________
;;; 
;;; 	  	        Generation Kit V3-2
;;; 			-------------------
;;; 
;;; 			   Masaru Tomita
;;; 		   Center for Machine Translation
;;; 		     Carnegie-Mellon University
;;; 
;;; 	_______________________________________________________
;;;     The following three files are required:
;;; 		util.lisp
;;; 		pseudo-unify.lisp
;;; 		compile-equations.lisp
;;; 
;;;     User's manual for Generation Kit V3-2 is available in
;;;       /../nl/usr/mt/Paper/genkit/genkit.mss (.PS)
;;; 	_______________________________________________________
;;; 
;;; 
;;; ________________________________________________________________

;;; ________________________________________________________________
;;; 
;;;  HISTORY
;;; 
;;; 19-Feb-88	Masaru Tomita (mt) at Carnegie-Mellon University
;;; 	Created.
;;; 03-Nov-88   Koichi Takeda made patches to process-rule so that
;;;             a generated body returns "null" when it failed,
;;;             instead of returning null string. Some debugging
;;;             aids are also embedded in a couple of functions
;;;
;;; 10-Nov-88 by EHN - COMPGEN now takes a second required argument,
;;;             TARGET, which denotes the target language. This symbol
;;;             is used as a prefix on each generator function name.
;;;             The variables storing the generator function name and
;;;             top level function name have been changed slightly
;;;             (see var defs, below, and COMPGEN defun).
;;;
;;; 25-Nov-88 by EHN -  now recognizes grammars in the DEFRULE
;;;             format used by GrETl.
;;; ________________________________________________________________


;;; ________________________________________________________________
;;; 
;;; 	Global Variable DECLARATION and INITIALIZATION
;;; ________________________________________________________________

;;; Special strings
;;; 
(defparameter %null-string% '|""|)
(defparameter %blank-space% '|" "|)

;;; Constituent list
;;; Useful when a path name is composed.
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;; Names of input/output files and streams.
 ;;; 
(defvar *input-gra-file-name*)
(defvar *output-gra-file-name*)
(defvar *output-gra-file-stream*)

;;; WILD-CARD-CHARACTER definition
;;; If rhs is %, it generates the value in the value slot.
;;; 
(defparameter *wild-card-character* '%)

;;; Prefix of generation functions, default "GG-".
;;; 

;;; 10-Nov-88 by EHN - two variables, one with the old name.

(defvar *gen-fun-name* "GG-")
(defvar *gen-fun-prefix*)

;;; Top level generation function name, default "GENERATOR".
;;; 

;;; 10-Nov-88 by EHN - two variables, one with the old name.

(defvar *top-level-gen-fun* "GENERATOR")
(defvar *top-level-gen-fun-name*)

;;; Start Symbol Name, default '<START>
;;; 
(defparameter *start-symbol* '<start>)

;;; 
;;; *RULES* is a hash table of rules indexed by lhs
;;; 
(defvar *rules*)

;;; The variable *global-variable-statements* contains a list
;;; of forms to be added at the top of each runtime linearizer file.
;;; 
(defvar *global-variable-statements*)
(setq *global-variable-statements* nil)

;;; 07-Mar-88 by EHN
;;; The variable *TRACE-RULES* determines:
;;;
;;; 1) if trace-printing calls are to be built into compiled rules, and
;;; 2) whether tracing is enabled during generation.

(defvar *trace-rules* nil)

;;; 07-Mar-88 by EHN
;;; Variable *TRACE-RULE-NUMBER is used to number the rules that are
;;; processed for each category.

(defvar *trace-rule-number*)

;;; 07-Mar-88 by EHN
;;; Variable *TRACE-RULE-INDENT* holds the current indent level in
;;; recursive rule invocation (for tracing).

;;; 07-Mar-88 by EHN

;(defmacro gentrace (string &rest args)
;  `(cond (*trace-rules*
;          (format *standard-output* "~%Generator> ")
;          (spaces *trace-rule-indent*)
;          (format *standard-output* ,string ,@args))))

;;; 25-Oct-88 by EHN
;;;
;;; macro cannot be applied for funcalled in HP CommonLisp
;;; so we rewrite as a function:

(defun quote-list (list)
  (let (result)
    (dolist (item list result)
      (setf result (nconc result (list (list 'quote item)))))))

(defun gentrace (string &rest args)
 (cond (*trace-rules*
          (format *standard-output* "~%Generator> ")
          (spaces *trace-rule-indent*)
          (eval `(format *standard-output* ,string ,@(quote-list args))))))

;;; 07-Mar-88 by EHN
;; For indenting the output stream; useful for tracing.

(defun spaces (n &optional (stream *standard-output*))
  (dotimes (x n nil) (write-char #\Space stream)))

;;; 07-Mar-88 by EHN
;;; for controlling the indentation of rule tracing

(defvar *trace-rule-indent*)
(defvar *trace-rule-indent-factor* 2)

;;; ___________________________________________________________________
;;; 
;;; COMPGEN is the top-level function.  It reads ".gra" file
;;; and produces "_gen.lisp" file which implements the linearlizer.
;;; 

;;; 07-Mar-88 by EHN - top-level fn now zeroes the trace indent var.
;;; 10-Nov-88 by EHN - now takes required target language argument. Should
;;;                    be a symbol (like 'E or 'J).

(defun compgen (gra-file &optional target)
    (cond (target 
           (setq *gen-fun-prefix* 
             (concatenate 'string (lisp::symbol-name target) "-" *gen-fun-name*))
           (setq *top-level-gen-fun-name*
             (intern (concatenate 'string (lisp::symbol-name target)
                                  "-" *top-level-gen-fun*)))) 
      (t (setq *gen-fun-prefix* *gen-fun-name*)
         (setq *top-level-gen-fun-name* (intern *top-level-gen-fun*))))
    
	; Initialize file names.
	; 
    (setq *input-gra-file-name* (concatenate 'string gra-file ".gra"))
    (setq *output-gra-file-name* (concatenate 'string gra-file "_gen.lisp"))
    (setq *output-gra-file-stream*
	   (open *output-gra-file-name* :direction :output
				        :if-exists :new-version))
    (setq *global-variable-statements* nil)
    
	; read input file (each rule is preprocessed) and
 	; make a hash table indexed by the lhs.
      	; READ-FILE-LIST defined in UTIL.			 
 	; 
    (let* ((rule-list (read-gen-rules *input-gra-file-name*)))
       (setq *rules* (make-hash-table))
       (dolist (rule rule-list)
	  (push rule (gethash (car rule) *rules*)))
	; 
	; Define the top level function GENERATOR
	; 
       (push `(defun ,*top-level-gen-fun-name* (x)
                 (setq *trace-rule-indent* 0)
		 (,(create-f-name *start-symbol*) x))
	     *global-variable-statements*)

       (format t "***** Start Writing ~S~%" *output-gra-file-name*)

	;	
 	; Write general statements to output file.
	; 
       (dolist (statement *global-variable-statements*)
	      (princ statement *output-gra-file-stream*)
      	      (terpri *output-gra-file-stream*))
	 
	; Each element of the hash table is a
	; list of rules with the same lhs.
	; For each element, apply PROCESS-RULES.
	;  				
       (maphash #'process-rules *rules*))

	; Close output file.
	; 
    (close *output-gra-file-stream*)
    (format t "***** End Writing ~S~%" *output-gra-file-name*)
    (format t "***** Start Loading ~S~%" *output-gra-file-name*)
    (load *output-gra-file-name*)
    (format t "***** End Loading ~S~%" *output-gra-file-name*))
    

;;; ________________________________________________________________
;;;
;;;   GENRULE-PREPROCESS preprocesses one rule
;;;
;;;
;;; 25-Nov-88 by EHN - added code to handle format used by GrETl
;;;                    (see document for details)

(defun gen-rule-preprocess (rule)
  ;;(printout "~%Rule head: ~a" (first rule))
  (cond
	   ;; If macro or function definition, do define.
	   ;;
        ((member (car rule) (list 'defmacro 'defun)) (eval rule) nil)

	   ;; If sub-grammar inclusion, load "_gen.lisp" files.
	   ;;
	((member (car rule) (list '@lex '@gra)) 
	   ;; Koichi modified the following code 11/03/88
	 (push (list 'load-gen-files (list 'quote 
	       (mapcar (function prin1-to-string) (cdr rule))))
		*global-variable-statements*))

           ;; If macro call, expand the macro.
	   ;;
        ((macro-function (car rule))
	 (mapcan #'gen-rule-preprocess (macroexpand rule)))

	   ;; Make sure that the rule is for parsing by looking at
	   ;; its arrow.  If so, return the rule (without arrow).
	   ;;
	((member (second rule) (list '<==> '<--> '==> '-->))
	 (list rule))
        ((eq 'defgrammar (first rule)) ; ignore, only used by GrETl
         nil)
        ((eq 'defrule (first rule))    ; strip off extra layer of list
         (gen-rule-preprocess (second rule)))

	   ;; Otherwise, return nil.
	   ;;
        (t nil)))


;;;
;;; LOAD-GEN-FILES loads a list of files with "_gen.lisp" extention.
;;; 
(defun load-gen-files (file-list)
  (dolist (file file-list)
    (load (concatenate 'string file "_gen.lisp"))))

;;; 
;;;    READ-GEN-FILE reads a grammar (list of rules), and
;;;    each rule is preprocessed.
;;; 
(defun read-gen-rules (file)
 (let ((rule-list nil))
  (format t "***** Start Reading ~A~%" *input-gra-file-name*)
  (with-open-file (ifile file :direction :input)
    (do ((rule (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq rule '%eof%))
      ;;; Koichi inserted following debugger lines 11/03/88
      (if (equal *trace-rules* 'all)
	  (gentrace "Reading ~a" (car rule)))
      ;;; End Debugger
      (setq rule-list (append rule-list (gen-rule-preprocess rule)))))
  (format t "***** End Reading ~A~%" *input-gra-file-name*)
  rule-list))

;;; _________________________________________________________________
;;; 
;;; PROCESS-RULES takes a list of rules with the same lhs, and writes
;;; out one function whose name is GG-lhs.
;;;
;;; Example:
;;; 
;;;  (DEFUN GG-S (X0)
;;; 	(OR  (.. code for the first rule ..)
;;; 	     (.. code for the second rule ..)
;;; 	     ......))
;;; 

;;; 07-Mar-88 by EHN: added bookkeeping (reset rule trace num)
;;;                   trace entry to fns

(defun process-rules (lhs rules)
        
   ;;; Koichi inserted following debugger lines 11/03/88
   (if (equal *trace-rules* 'all)
	(gentrace "Processing ~a" (car rule)))
   ;;; End Debugger
   ; Reset the rule number for tracing
   (setq *trace-rule-number* 0)
   	; Determine its function name
	; 
   (let* ((func-name (create-f-name (symbol-name lhs)))

	; Construct the function's body.
	; PROCESS-RULE is called for each rule.
	; The results of PROCESS-RULE is
	; "or-ed";  thus as soon as one rule
	; 
   	  (func-body
		`(defun ,func-name (x0)
		   ;; Koichi modified the following tracer call 11/03/88
                   (if (equal *trace-rules* 'all)
		       (gentrace |"~a called with ~a"| ',func-name x0)
		       (gentrace |"~a called"| ',func-name))
		   ;; 
                   (let (result)
                     (setq *trace-rule-indent*
                       (+ *trace-rule-indent* 
                          *trace-rule-indent-factor*))
		     (setq result
                       (or ,@(map-dolist (rule (reverse rules))
			       (process-rule rule))))
                     (setq *trace-rule-indent*
                       (- *trace-rule-indent* 
                          *trace-rule-indent-factor*))
                     (gentrace |"~a returns ~a"| ',func-name result)
                     result))))
				
	; Then write the body out.
	; 
	(PRINC func-body *output-gra-file-stream*)
	(terpri *output-gra-file-stream*)))

;;; _________________________________________________________________
;;; 
;;; PROCESS-RULE returns a piece of code for one rule.
;;;		 
;;; Example:
;;;  (LET ((X `(((X0 ,X0)))))
;;;   (AND (P=P (X1) (X0 SUBJ))
;;; 	   (P=P (X2) (x0))
;;;        ...... other compiled-equations
;;;  	   ......
;;;        (OR-DOLIST (FS X)
;;; 		(LET ((RESULT-STRING ""))
;;; 		  (.. code for recurseive function calls ..)))))
;;;
;;; 

;;; 07-Mar-88 by EHN: Added ability to trace rules.
;;; 25-Nov-88 by EHN: Changed trace output line by replacing "returns:"
;;;                   with "returns" (was bombing GrETl).

(defmacro trace-rule-call (cat number form)
  `(let ((result ,form))
     (if *trace-rules* 
         (gentrace "Rule ~a for ~a returns ~a" 
           ,number ',cat result))
     result))

(defun process-rule (rule &optional number)
    (let ((lhs (first rule))
	  (arrow (second rule))
	  (rhs-list (third rule))
	  (statements (fourth rule)))
      (if *trace-rules*
	`(trace-rule-call ,lhs ,(incf *trace-rule-number*)
           (let ((x `(((x0 ,x0)))))
   	     (and
	       ,@(cdr (compile-statements statements))
	       (or-dolist (fs x)
		     (let ((result-string ,%null-string%))
			,(rhs-funcalls rhs-list arrow)
			;; Koichi corrected the following line 11/03/88
			;; result-string)))))
			(if (equal result-string |""|) nil result-string))))))
        `(let ((x `(((x0 ,x0)))))
	     (and
	       ,@(cdr (compile-statements statements))
	       (or-dolist (fs x)
		     (let ((result-string ,%null-string%))
			,(rhs-funcalls rhs-list arrow)
			;; Koichi corrected the following line 11/03/88
			;; result-string)))))))
			(if (equal result-string |""|) nil result-string))))))))


;;; ________________________________________________________________
;;; 
;;; RHS-FUNCALLS returns a piece of code for recursive function
;;; calls.
;;; 
(defun rhs-funcalls (rhs-list arrow)
     (let ((funcalls nil)(word-boundary ""))
	 (dotimes (i (length rhs-list) (cons 'and funcalls))
	     (setq word-boundary 
		(if (= i 0) %null-string% (decide-word-boundary arrow)))
	     (setq funcalls
		 (append funcalls
		   (list (rhs-funcall (nth i rhs-list)
			    	      (nth (1+ i) constit-list)
    	 			      word-boundary)))))))

;;; ________________________________________________________________
;;; 
;;; RHS-FUNCALL returns a piece of code for a function call for
;;; a rhs nonterminal.
;;; 
;;;  RHS is a right hand side symbol.
;;;  XN contains one of x1, x2,.... i.e., position of the rhs.
;;;  WORD-BOUNDARY contains either "" or " ".
;;; 
(defun rhs-funcall (rhs xn word-boundary)

  (cond

	; If rhs is a nonterminal, call a GG-rhs function.
	; 
     ((non-term rhs)
      `(let ((temp nil))
          (setq temp (apply ',(create-f-name rhs)
				 (list (getvalue fs '(,xn)))))
	  (if temp (setq result-string
			(concatenate 'string
			   result-string ,word-boundary temp))
	;  nil))) this statement is replace with the following by Koichi
	      (progn (setf result-string |""|) nil))))

	; If rhs is a wild-card-character, use value in value slot.
	;
     ((eq rhs *wild-card-character*)
      `(setq result-string
		(concatenate 'string
		    result-string
		    ,word-boundary
		    (make-it-string (getvalue fs '(,xn value))))))

	; If rhs is a terminal, simply use "rhs".
 	; 			
     ;; Koichi added the following case to handle special characters 11/03/88
     ((member rhs '(\: \; \. \" \\ \' \( \) \!))
      `(setq result-string
	       (concatenate 'string
		  result-string ,word-boundary
		  (symbol-name ,(concatenate 'string "'\\"
				(symbol-name rhs))))))
     (t
      `(setq result-string
	       (concatenate 'string
	  	  result-string ,word-boundary (symbol-name ',rhs))))))

;;; ___________________________________________________________________
;;; 
;;; 	Miscellaneous Functions
;;; ___________________________________________________________________

;;; 
;;;  MAKE-STRING
;;;   If x is a symbol or number, make it string.
;;;   If x is a string, do nothing
;;; 

(defun make-it-string (x)
	(if (symbolp x) (symbol-name x)
	    (if (numberp x) (prin1-to-string x) x)))

;;; 
;;;  CREATE-F-NAME
;;;   Example:  (create-f-name '<NP>)  returns a symbol "GG-NP".
;;; 
(defun create-f-name (lhs)
  (let ((lhs-strip (string-trim '(#\< #\>) lhs)) suf)
    (setq lhs-strip (concatenate 'string *GEN-FUN-PREFIX* lhs-strip))))

;;; 
;;;  DECIDE-WORD-BOUNDARY returns either "" or " ", depending
;;;  on the type of the arrow.  <--> or --> is used for a lexical
;;;  or morphological rule, where you don't want to put a space
;;;  in between rhs.
;;;   
(defun decide-word-boundary (arrow)
     (case arrow
       ((<==> ==>) %blank-space%)
       ((<--> -->) %null-string%)))

;;; 
;;;  NON-TERM returns t if the symbol is a non-terminal (e.g. <NP>).
;;;  It checks if the first charactor is "<".
;;; 
(defun non-term (s)
  ;; Koichi added a case when s is a number 11/02/88
  (cond ((numberp s) nil)
        (t (and (atom s) (equal #\< (elt (symbol-name s) 0))))))

;;; 
;;;  REGISTERP returns t if the object is one of x0, x1, x2, x3 ...
;;; 
(defun registerp (object)
  (member object constit-list))

;;;
;;;  TR    Interface to parsing
;;;
(defun tr (string &aux save-value save-flag)
  (setq save-flag *parse-return-value*)
  (setq *parse-return-value* t)
  (setq save-value (generator (cons '*OR* (parse string))))
  (setq *parse-return-value* save-flag)
  save-value)

;;; ________________________________________________________________
;;; 
;;; 	  	      Transformation Kit V3-2
;;; 		      -----------------------
;;; 
;;; 			   Masaru Tomita
;;; 		   Center for Machine Translation
;;; 		     Carnegie-Mellon University
;;; 
;;; 	_______________________________________________________
;;;     The following two files are required:
;;; 		util.lisp
;;; 		pseudo-unify.lisp
;;; 
;;;     User's manual for Generation Kit V3-2 is available in
;;;       /../nl/usr/mt/Paper/trfkit/trfkit.mss (.PS)
;;; 	_______________________________________________________
;;; 
;;; 
;;; ________________________________________________________________

;;; ________________________________________________________________
;;; 
;;;  HISTORY
;;; 
;;; 23-Feb-88	Masaru Tomita (mt) at Carnegie-Mellon University
;;; 	Created.
;;; ________________________________________________________________


;;; ________________________________________________________________
;;; 
;;; 	Global Variable DECLARATION and INITIALIZATION
;;; ________________________________________________________________


;;; Constituent list
;;; 
(defconstant CONSTIT-LIST 
	'(x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10
	  x11 x12 x13 x14 x15 x16 x17 x18 x19 x20
	  x21 x22 x23 x24 x25 x26 x27 x28 x29 x30
	  x31 x32 x33 x34 x35 x36 x37 x38 x39 x40))

;;; Names of input/output files and streams.
;;; 
(defvar *input-gra-file-name*)
(defvar *output-gra-file-name*)
(defvar *output-gra-file-stream*)

;;; The variable *global-variable-statements* contains a list
;;; of forms to be added at the top of each runtime linearizer file.
;;; 
(defvar *global-variable-statements*)
(setq *global-variable-statements* nil)



;;; ___________________________________________________________________
;;; 
;;; COMPTRF is the top-level function.  It reads ".gra" file
;;; and produces "_trf.lisp" file which implements the transformer.
;;; 
(defun comptrf (gra-file)
  
  (let ((rules nil))
	 
	; Initialize file names.
	; 
    (setq *input-gra-file-name* (concatenate 'string gra-file ".gra"))
    (setq *output-gra-file-name* (concatenate 'string gra-file "_trf.lisp"))
    (setq *output-gra-file-stream*
	   (open *output-gra-file-name* :direction :output
				        :if-exists :new-version))
    (setq *global-variable-statements* nil)
    
	; read input file (each rule is preprocessed) and
 	; make a hash table indexed by the lhs.
      	; READ-FILE-LIST defined in UTIL.			 
 	; 
  
       (format t "***** Start Writing ~S~%" *output-gra-file-name*)

	;	
 	; Write general statements to output file.
	; 
       (dolist (statement *global-variable-statements*)
	      (princ statement *output-gra-file-stream*)
      	      (terpri *output-gra-file-stream*))

       (setq rules (read-trf-file *input-gra-file-name*))
       (dolist (rule rules)
	  (comptrf-1 rule))

	; Close output file.
	; 
    (close *output-gra-file-stream*)
    (format t "***** End Writing ~S~%" *output-gra-file-name*)
    (format t "***** Start Loading ~S~%" *output-gra-file-name*)
    (load *output-gra-file-name*)
    (format t "***** End Loading ~S~%" *output-gra-file-name*)))
    

;;; ________________________________________________________________
;;;
;;;   TRF-RULE-PREPROCESS preprocesses one transformation rule.
;;;
(defun trf-rule-preprocess (rule)
  (cond
	   ;; If macro or function definition, do define.
	   ;;
        ((member (car rule) (list 'defmacro 'defun)) (eval rule) nil)

	   ;; Ignore @lex and @gra.			
	   ;;
	((member (car rule) (list '@lex '@gra)) 
	 nil)

           ;; If macro call, expand the macro.
	   ;;
        ((macro-function (car rule))
	 (mapcan #'trf-rule-preprocess (macroexpand rule)))

	   ;; Make sure that the rule is for parsing by looking at
	   ;; its arrow.  If so, return the rule (without arrow).
	   ;;
	((member (second rule) (list '<-- '<== '<==> '<--> '==> '-->))
	 (list rule))

	   ;; Otherwise, return nil.
	   ;;
        (t nil)))


;;;
;;; LOAD-TRF-FILES loads a list of files with "_trf.lisp" extention.
;;; 
(defun load-trf-files (file-list)
  (dolist (file file-list)
    (load (concatenate 'string file "trf.lisp"))))

;;; 
;;;    READ-TRF-FILE reads a grammar (list of rules), and
;;;    each rule is preprocessed.
;;; 
(defun read-trf-file (file)
 (let ((rule-list nil))
  (format t "***** Start Reading ~A~%" *input-gra-file-name*)
  (with-open-file (ifile file :direction :input)
    (do ((rule (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq rule '%eof%))
      (setq rule-list (append rule-list (trf-rule-preprocess rule)))))
  (format t "***** End Reading ~A~%" *input-gra-file-name*)
  rule-list))


(defun comptrf-1 (rule)

  (let* ((lhs (first rule))
	 (arrow (second rule))
	 (rhs-list (third rule))
	 (rhs (if (atom rhs-list) (list rhs-list) rhs-list))
	 (statements (fourth rule))
	 (reg-list (subseq CONSTIT-LIST 1 (1+ (length rhs))))
	 (cons-list (mapcar #'(lambda (reg) `(list (quote ,reg) ,reg))
			      reg-list))
	 (fun-name (concatenate 'string
		      (symbol-name lhs)
		      (if (member arrow '(==> -->))
			   "-to-" "-from-")
		      (symbol-name (car rhs))))
	 (fun-body `(defun ,fun-name ,reg-list
		        (let ((x (list (list ,@cons-list))))
			    ,(compile-statements statements)
			    (getvalue* x '(x0))))))
    (princ fun-body *output-gra-file-stream*)
    (terpri *output-gra-file-stream*)))

;;;
;;; -------------------------------------------------------------
;;;  		  English Morphology Package 
;;; 		  For Parsing and Generation
;;;
;;;                     Masaru Tomita
;;; -------------------------------------------------------------

;;;
;;; TOP LEVEL FUNCTIONS:
;;; (INIT-MORPH &key gen-only basic-only) - initialize the package.
;;;	  If you use this only for generation, set :gen-only to t.
;;;	  If you only need the basic 3000 words (rather than 10000),
;;;       set :basic-only to t.
;;; (PARSE-ENG-WORD "word") - do the morphlogical analysis,
;;;		 look up the dictionary, and return a f-structure.
;;; (GEN-ENG-WORD f-structure) - look up the dictionary, and
;;;		 return a surface string.
;;;

;;;
;;;  Global Variables
;;;
(defvar *eng-dict-file*)   ;; English dictionary file name
(setq *eng-dict-file* "/../nl/usr/nlp/ibm/dict/eng-dict.basic")
(defvar *user-dict-files*)  ;; List of user defined dictionaries
(setq *user-dict-files* nil)

(defvar *eng-dict-hash*)   ;; hash table for eng-dict

;;;
;;;  PUSH-NEW pushes ITEM to LIST, if ITEM does not already exists
;;;  in LIST.
;;;
(defmacro push-new (item list)
  `(unless (member ,item ,list :test #'equal) (push ,item ,list)))

;;;
;;;  READ-DICT reads a dictionary and builds a hash table.
;;;
(defun read-dict (file &key gen-only basic-only)
  (format t " - Reading ~A~%" file)
  (with-open-file (ifile file :direction :input)
    (do ((obj (read ifile nil '%eof%)(read ifile nil '%eof%)))
	((eq obj '%eof%))
      (let* ((headword (car obj))
	     (basic (eq (second obj) '*))
	     (body (if basic (cddr obj) (cdr obj)))
	     (past (second (member :past body)))
 	     (pastpart (second (member :pastpart body)))
 	     (pl (second (member :pl body))))
       (when (and (or basic (not basic-only))
		  (or (not gen-only) past pastpart pl))
	(push body (gethash headword *eng-dict-hash*))
	(when (not gen-only)
 	  (if past
	      (push-new (list 'irreg :past-of headword)
			(gethash past *eng-dict-hash*)))
	  (if pastpart
	      (push-new (list 'irreg :pastpart-of headword)
			(gethash pastpart *eng-dict-hash*)))
	  (if pl
	      (push-new (list 'irreg :pl-of headword)
			(gethash pl *eng-dict-hash*))))))))

  (format t " - ~A read~%" file))

;;;
;;;  KEYVALUE returns the item immediately after KEY in
;;;  a list DICT-LINE.    (keyvalue :aaa '(ww ee :aaa ss :bbb ee))
;;;  will return ss.
;;;
(defun keyvalue (key dict-line)
   (second (member key dict-line)))

;;;
;;;  ENG-DICT-PICKUP takes a word in a root form, and returns
;;;  a f-structure for it.  
;;;
(defun eng-dict-pickup (root &optional (cat nil) &aux dict-lines)
  (setq dict-lines (gethash root *eng-dict-hash*))
  (append-dolist (dict-line dict-lines)
   (when (or (null cat)(eq cat (first dict-line)))
    (case (first dict-line)
     (V  (let ((valency (keyvalue :valency dict-line)))
	   (if (null valency) (setq valency 'TRANS))
	  `(((root ,root)
	     (cat V)
	     (valency ,valency)))))
     (N  (let ((countable (member 'c dict-line))
	       (uncountable (member 'u dict-line))
	       (count nil))
           (cond ((and countable uncountable)
		  (setq count '(*OR* + -)))
		 (uncountable (setq count '-))
		 (t (setq count '+)))
          `(((root ,root)
	     (cat N)
	     (count ,count)))))
     (IRREG
	(let* ((form (second dict-line))
	       (realroot (third dict-line))
	       (realcat (if (eq form :pl-of) 'N 'V))
	       (fs-list (eng-dict-pickup realroot realcat)))
	  (case form
	    (:pl-of (map-dolist (fs fs-list)
			(cons '(number pl) fs)))
	    (:past-of (map-dolist (fs fs-list)
			  (cons '(form past) fs)))
	    (:pastpart-of (map-dolist (fs fs-list)
			      (cons '(form pastpart) fs))))))
      (t `(((root ,root)
	    (cat ,(first dict-line))))))
	)))

;;;
;;;  INIT-MORPH initializes this package.
(defun init-morph (&key gen-only basic-only)
  (setq *eng-dict-hash* (make-hash-table :test #'equal))
  (dolist (file *user-dict-files*)
    (read-dict file))
  (read-dict *eng-dict-file* :gen-only gen-only :basic-only basic-only))

;;;
;;;  PARSE-ENG-MORPH analyzes morphology of a given word,
;;;  without consulting the dictionary.
;;;
(defun parse-eng-morph (word &aux result-list rev-word)

  (setq rev-word (reverse (coerce word 'list)))

  ;;
  ;;   Verb +S   and Noun +S
  ;;
  (when (and (< 3 (length rev-word))
	     (eq (first rev-word) #\s)
  	     (not (member (second rev-word)
			  '(#\s #\u #\z))))
   (push (list (coerce (reverse (cdr rev-word)) 'string)
	       '+S)
	 result-list))

  (when (and (< 3 (length rev-word))
  	     (eq (first rev-word) #\s)
  	     (eq (second rev-word) #\e)
	     (member (third rev-word) '(#\s #\z #\h #\o)))
   (push (list (coerce (reverse (cddr rev-word)) 'string)
	       '+S)
	 result-list))

  (when (and (< 4 (length rev-word))
  	     (eq (first rev-word) #\s)
  	     (eq (second rev-word) #\e)
  	     (eq (third rev-word) #\v))
   (push (list (coerce (reverse (cons #\f (cdddr rev-word))) 'string)
	       '+S)
	 result-list))

  (when (and (< 4 (length rev-word))
  	     (eq (first rev-word) #\s)
  	     (eq (second rev-word) #\e)
  	     (eq (third rev-word) #\i)
	     (not (member (fourth rev-word) '(#\a #\i #\u #\e #\o))))
   (push (list (coerce (reverse (cons #\y (cdddr rev-word))) 'string)
	       '+S)
	 result-list))

  ;;
  ;;   Verb +ED
  ;;
  (when (and (< 3 (length rev-word))
  	     (eq (first rev-word) #\d)
  	     (eq (second rev-word) #\e))
   (push (list (coerce (reverse (cddr rev-word)) 'string)
	       '+ED)
	 result-list)
   (if (eq (third rev-word)(fourth rev-word))
       (push (list (coerce (reverse (cdddr rev-word)) 'string)
	           '+ED)
	     result-list)
       (push (list (coerce (reverse (cdr rev-word)) 'string)
		   '+ED)
	     result-list))
   (if (and (eq (third rev-word) #\k) (eq (fourth rev-word) #\c))
       (push (list (coerce (reverse (cdddr rev-word)) 'string) '+ED)
	     result-list))
   (if (eq (third rev-word) #\i)
       (push (list (coerce (reverse (cons #\y (cdddr rev-word))) 'string)
		   '+ED)
	 result-list)))

  ;;
  ;;   Verb +ING
  ;;
  (when (and (< 4 (length rev-word))
  	     (eq (first rev-word) #\g)
  	     (eq (second rev-word) #\n)
	     (eq (third rev-word) #\i))
   (push (list (coerce (reverse (cdddr rev-word)) 'string)
	       '+ING)
	 result-list)
   (if (eq (fourth rev-word)(fifth rev-word))
       (push (list (coerce (reverse (cddddr rev-word)) 'string)
		   '+ING)
	     result-list)
       (push (list (coerce (reverse (cons #\e (cdddr rev-word))) 'string)
		   '+ING)
	     result-list))
   (if (and (eq (fourth rev-word) #\k) (eq (fifth rev-word) #\c))
       (push (list (coerce (reverse (cddddr rev-word)) 'string) '+ING)
	     result-list))
   (if (eq (fourth rev-word) #\y)
       (push (list (coerce (reverse `(#\e #\i .,(cddddr rev-word))) 'string)
		   '+ING)
	     result-list)))
 
 (cons (list word '+NIL) result-list)	;;; return from MORPH-ENG
)  

;;;
;;;  PARSE-ENG-WORD takes a word in any form, analyzes its morphology,
;;;  looks up the dictionary, and returns a f-structure.
;;;  
(defun parse-eng-word (word &aux root+forms result-fs)
  (setq root+forms (parse-eng-morph word))
  (setq result-fs
   (append-dolist (root+form root+forms)
    (let* ((root (first root+form))
	   (form (second root+form)))
      (case form
	(+ING (map-dolist (fs (eng-dict-pickup root 'V))
		(cons '(form prespart) fs)))
	(+ED (map-dolist (fs (eng-dict-pickup root 'V))
		(cons '(form (*OR* past pastpart)) fs)))
	(+S  (append
	        (map-dolist (fs (eng-dict-pickup root 'V))
	  	    (cons '(form present3sg) fs))
		(map-dolist (fs (eng-dict-pickup root 'N))
		    (cons '(number pl) fs))))
	(+NIL (eng-dict-pickup root))))))

  (list-to-value result-fs)	;; return
 )

;;;
;;;  GEN-ENG-MORPH generates a surface form of ROOT,
;;;  given the FORM information, without looking up the dictionary.
;;;
(defun gen-eng-morph (root form &key syl-double)
 (let ((word nil))
  (setq root (reverse (coerce root 'list)))
  (case form
    (+S (cond ((and (eq (first root) #\y)
		    (not (member (second root) (list #\a #\i #\u #\e #\o))))
	       (setq word (append '(#\s #\e #\i) (cdr root))))
	      ((or (member (first root) (list #\a #\i #\u #\o #\s #\z #\x))
		   (and (eq (first root) #\h)
		        (member (second root) '(#\c #\s))))
	       (setq word (append '(#\s #\e) root)))
	      ((eql (first root) #\v)
	       (setq word (append '(#\s #\e v) (cdr root))))
	      (t (setq word (cons #\s root)))))
    (+ING
	(cond (syl-double
	       (setq word (append '(#\g #\n #\i) (cons (first root) root))))
	      ((and (eq (first root) #\e)
		    (not (member (second root) '(#\a #\i #\e #\o))))
	       (setq word (append '(#\g #\n #\i) (cdr root))))
	      ((and (eq (first root) #\e)
		    (eq (second root) #\i))
	       (setq word (append '(#\g #\n #\i #\y) (cddr root))))
	      ((eq (first root) #\c)
	       (setq word (append '(#\g #\n #\i #\k) root)))
	      (t (setq word (append '(#\g #\n #\i) root)))))
    (+ED
	(cond (syl-double
	       (setq word (append '(#\d #\e) (cons (first root) root))))
	      ((and (eq (first root) #\y)
		    (not (member (second root) '(#\a #\i #\u #\e #\o))))
	       (setq word (append '(#\d #\e #\i) (cdr root))))
	      ((and (eq (first root) #\e)
		    (not (member (second root) '(#\a #\i #\o))))
	       (setq word (append '(#\d) root)))
	      ((eq (first root) #\c)
	       (setq word (append '(#\d #\e #\k) root)))
	      (t (setq word (append '(#\d #\e) root))))))
  (coerce (reverse word) 'string)))

;;;
;;;  Get the value of SLOT.  If the value is *OR*, just take the first value.
;;;  This is used in generation.
;;;
(defun get-first-value (slot fs)
  (car (value-to-list (cadr (assoc slot fs)))))

;;;
;;;  GEN-ENG-WORD takes a f-structure, looks up the dictionary with
;;;  its root word to get morphological information, and generates
;;;  an appropriate surface form.
;;;
(defun gen-eng-word (fs &aux cat root)
  (setq fs (car (value-to-list fs)))
  (setq cat (get-first-value 'cat fs))
  (setq root (get-first-value 'root fs))
  (case cat
    (N (let ((number (get-first-value 'number fs)))
	 (cond ((not (eq number 'PL)) root)
	       (t (or (keyvalue :pl
				(assoc 'N (gethash root *eng-dict-hash*)))
		      (gen-eng-morph root '+S))))))
    (V (let  ((form (get-first-value 'form fs))
	      (syl-double nil))
	 (setq syl-double
		(keyvalue :syl-double
			  (assoc 'V (gethash root *eng-dict-hash*))))
         (case form 
	    (PRESPART (gen-eng-morph root '+ING :syl-double syl-double))
	    (PRESENT3SG (gen-eng-morph root '+S))
	    (PAST (or (keyvalue :past
				(assoc 'V (gethash root *eng-dict-hash*)))
		      (gen-eng-morph root '+ED :syl-double syl-double)))
	    (PASTPART (or (keyvalue :pastpart
				    (assoc 'V (gethash root *eng-dict-hash*)))
		          (gen-eng-morph root '+ED :syl-double syl-double)))
	    (t root))))
    (t root)))

	
;;;
;;;  HELP-MORPH
;;; 
(defun help ()
'|
TOP LEVEL FUNCTIONS:
 (INIT-MORPH &key gen-only basic-only)  
	  Initialize the package.
	  If you use this only for generation, set :gen-only to t.
	  If you only need the basic 3000 words (rather than 10000),
          set :basic-only to t.
    eg. (init-morph)
        (init-morph :gen-only t)

 (PARSE-ENG-WORD "word") 
	  Do the morphlogical analysis,
 	  look up the dictionary, and return a f-structure.
	  VERB's form is one of
		{PRESPART, PRESENT3SG, PAST, PASTPART, *UNDEFINED*}
	  N's number is one of
		{PL, *UNDEFINED*}
    eg. (parse-eng-word "putting")  returns
		((root "put")
		 (cat "v")
		 (form PRESPART)) 
    eg. (parse-eng-word "feet"  returns
		((root "foot")
		 (cat n)
		 (number pl))
   	  In case of ambiguity, it returns all f-structures
	  with *OR*.  

 (GEN-ENG-WORD f-structure)
	  Look up the dictionary, and return a surface string.
    eg. (gen-eng-word '((root "take")
			(form PASTPART)
			 .....         ))   returns "taken".
    eg. (gen-eng-word '((root "pencil")))   returns "pencil".


Global Variables

*eng-dict-file*  English dictionary file name.  It is set to
		 "/../nl/usr/nlp/ibm/dict/eng-dict.basic".
		 Please do not alter the original dictionary without
		 permission.

*eng-dict-hash*  Hash table containing the dictionary.



|)
(defun help ()
"
New Functions:
(I-LOADGRA gra-name-stem) 	- load a source grammar for the interpreter
				- No need to compile it
(IP sentence)		  	- parse a sentence with the interpreter
(DMODE n)			- n=1: show symbols parsed
				- n=2: and show rules applied
(TRACE-RULE n &optional i j)	- Trace rule n, from sentence position i to j.
				- i and j are optional
(UNTRACE-RULE)			- Untrace all rules
")

(defun acknowledge ()
"
------------------------------------------------------------------------------
The  Generalized  LR  Parser/Compiler Version 8.1 is the syntactic part of the
Universal Parser used in the CMU Machine Translation project.  It is based  on
Tomita's  Generalized  LR  Parsing  algorithm,  augmented  by  pseudo and full
unification packages.  The Generalized LR Parser/Compiler V8.1 is  implemented
in   Common  Lisp  and  no  window  graphics  is  used;  thus  the  system  is
transportable, in  principle,  to  any  machines  that  support  Common  Lisp.
Presently, the system is running on Symbolics 3600 Series, IBM RT PC's, and HP
Bobcat AI Workstations.

Those who are interested in obtaining this software should contact:  

    Masaru Tomita
    Associate Director
    Center for Machine Translation
    Carnegie-Mellon University
    Pittsburgh, PA15213, USA
    (412)268-3044
    mt@nl.cs.cmu.edu

Many  members of CMU Center for Machine Translation have made contributions to
the system development.  The runtime parser has been implemented  by  Hiroyuki
Musha,   Masaru  Tomita  and  Kazuhiro  Toyoshima.    The  compiler  has  been
implemented by Hideto Kagamida and Masaru  Tomita.    The  pseudo  unification
package  and  the  full  unification  package  have been implemented by Masaru
Tomita and Kevin Knight, respectively.   Steve  Morrisson,  Hideto  Tomabechi,
Eric  Nyberg  and  Hiroaki  Saito  also  made contributions in maintaining the
system.  Sample English grammars have been  developed  by  Donna  Gates,  Lori
Levin  and  Masaru  Tomita.    A sample Japanese grammar has been developed by
Teruko Mitamura.  A sample French grammar is being developed by  John  Velonis
and  Linda  Schmandt.    Other members who made indirect contributions in many
ways include Kouichi Takeda, Marion Kee, Sergei  Nirenburg,  Ralf  Brown,  and
especially Jaime Carbonell, the director of the center.

Funding  for  this  project  is  provided  by several private institutions and
governmental agencies in the United States and Japan.
------------------------------------------------------------------------------
")

(print "Type (ACKNOWLEDGE) for acknowledgements.")


(load "initialize.lisp" :if-does-not-exist nil)
